(/  cZ0UsOCO/<?3 

NRL  Memorandum  Report  3698 


The  Modified  Canadian  Spectral  Forecast 
Model:  Discussion  and  Documentation 


Walter  W.  Jones,  Rangarao  V . Mapala, 
and  Mark  R.  Schoeberl 

Plasma  Physics  Division 


March  1978 


) 

I 

I 


0 


D D C V 

tEraEffl.nET 


MIC  SI  1978 


nun 

HklSEtJ 


TTE 


B 


NAVAL  RESEARCH  LABORATORY 
Wash! n{t on,  D.  C. 


Approved  for  public  relesse;  distribution 

78  07 


A 


1 


SECURITY  CLASSIFICATION  OF  TmiS  PAGE  f»7*en  Dttm  Entered ) 


REPORT  DOCUMENTATION  PAGE 


report  number 


]2.  GOVT  ACCESSION  NO 


NRL  Memorandum  Report  3698 


" JHE  MhODIFIED  CANADIAN  SPECTRAL  JORECAST 

^odel:  gjscuSsioN  and  Documentation# 


Walter  W. /Jones,  Rangarao  V.lMadala  and  Mark  R.iSchoeberl 


9 PERFORMING  ORGANIZATION  NAME  AND  ADDRESS 

Naval  Research  Laboratory 
Washington,  D.C.  20375 

II  CON^ROLL-NG  OFFICE  NAME  AND  ADDRESS 

Director  I / j 

Naval  Environmental  Prediction  Research  Facility  s— < 

Monterey,  Calif. 

14  MONITORING  AGENCY  NAME  A ADDRESSES  dlHerent  Irom  Controlling  Otllce) 

i)Xh/T^  h’  l yj-e  pti3o\  It  — 

A. — -r 

«6  distribution  statement  rci  this  ReporT)  L. 

Approved  for  public  release;  distribution  unlimited. 


READ  INSTRUCTIONS 
BEFORE  COMPLETING  FORM 

'»  RECIPIENT'S  CAT  AlCG  NUMBER 


5 TYPE  OF  REPORT  A PERIOD  COVERED 

Interim  report:  July,  1976  to 
December,  1977. 

6 PERFORMING  ORG.  REPORT  NUMBER 


I B.  CONTRACT  OR  GRANT  NUMBER'*/ 


10  PROGRAM  ELEMENT.  PROJECT,  TASK 
AREA  A WORK  UNIT  NUMBERS 


NRL  Problem  A03-23 
Project  WF52-551-713 


4Mar«h*»78  / - 

’HTTjTJBlTr of  pages" 

193 

15  SECURITY  CLASS,  (ot  fhla  repo-t. 


UNCLASSIFIED 


15a  Reclassification  downgrad-ng 
iH  Schedule 


17 DISTRIBUTION  STATE 


mbatrect  entered  In  Block  20,  1 1 different  Ire, 


l»  SUPPLEMENTARY  NOTES 


This  research  was  sponsored  by  Naval  Environmental  Prediction  Research  Facility  Block  Fund  under 
Project  WF52-551-713 


1 19  KEY  WOROS  (Continue  on  reverse  aide  II  naceaaery  end  Idej 


block  ntmtber) 


General  Circulation  Model 
Spectral  Forecast  Model 
Atmospheric  Modeling 


20  I^TPACT  ( Continue  on  reverae  aide  It  nec»»»*ry  mnd  Identity  by  block  number) 

The  Canadian  spectral  forecast  model  developed  by  Daley,  et  al.,  (1976)  has  been  modified  for 
use  in  medium  range  forecasts.  These  modifications  involve  primarily  the  vertical  differencing 
scheme  (which  is  changed  to  conserve  energy),  the  dry  convective  adjustment,  and  some  of  the 
program  structure  which  allows  the  model  to  run  efficiently,  on  the  Toitat  lnitrument-ComputPT> 
^ (ASG).  Results  of  a medium  range  integration  are  compared  using  both  the  modified  and  original 
model  and  actual  weather  observation. 


DD  , jan  73  1473  EDITION  OF  t NOV  6S  IS  OBSOLETE 

S'N  0102-LF -01 4-6601 


■ SECURITY  CL>SSIUfc/TION  OF.TPIIS  PAGE  tan  Dmlm 

78  0?  JW  0 ■ 

isa 


CONTENTS 


I.  Introduction  

II.  Model  Description  and  Equations  

III.  Differencing  for  Energy  Conserving  Vertical  Grid 


IV.  Comparison  of  Models  13 


Acknowledgments 
References 


Appendix  I 


ui-.  i 

6ai 


L 

: 

| kimwm  bus  f 

1 Dkst.  A MIL  *»l/o 

* 

QQ 


THE  MODIFIED  CANADIAN  SPECTRAL  FORECAST 
MODEL:  DISCUSSION  AND  DOCUMENTATION 

L INTRODUCTION 

The  Canadian  spectral  forecast  model  (CSFM)  is  a multi-dimensional  global  model  of  the 
atmosphere  in  sigma  coordinates  using  spectral  decomposition  of  dependent  variables  in  the 
horizontal  (Daley,  et  al.,  1976).  This  model  is  currently  being  used  at  NRL  for  various  atmos- 
pheric  research  programs.  It  was  chosen  because  of  its  computational  efficiency  and  extensive 
documentation.  | 

However,  one  of  the  disadvantages  of  the  CSFM  is  that  it  does  not  conserve  energy  with 
its  vertical  differencing  scheme.  We  have,  therefore,  replaced  the  vertical  differencing  scheme 
with  one  which  conserves  energy.  In  connection  with  this  modification,  we  have  also  altered 
the  boundary  layer  approximations  and  the  dry  convective  adjustment  procedure.  Other  minor 
changes  have  been  made  to  the  original  CSFM  to  allow  the  model  to  run  on  the  NRL’s  Texas 
Instrument  computer  (ASC).  The  entire  modified  code  is  documented  in  Appendix  I. 

In  the  section  which  follows,  we  describe  briefly  the  procedure  used  by  the  CSFM  to 
generate  forecasts  and  introduce  the  hydrodynamic  equations  solved  by  the  model.  Section  III 
gives  a derivation  of  the  modified  equations  used  for  the  energy  conserving  grid,  and  the  final 
section  compares  the  results  obtained  from  these  two  models. 

'Manuscript  submitted  January  16.  1978. 
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II.  MODEL  DESCRIPTION  AND  EQUATIONS 

The  CSFM  is  primarily  a spectral  model  which  implies  that  the  dependent  variables  have 
been  expanded  (in  the  horizontal)  in  terms  of  spherical  harmonics.  The  use  of  fast  numerical 
transforms  between  the  grid  network  and  the  spectral  system  gives  this  method  computational 
efficiency  for  relatively  small  grids.  Further,  since  the  horizontal  differentiation  is  done  "exact- 
ly", a spectral  model  conserves  energy  for  the  horizontal  grid  up  to  the  truncation  of  the  spec- 
tral series  and  nonlinear  aliasing  generated  on  the  Gaussian  grid. 

For  the  vertical  grid,  the  CSFM  divides  the  atmosphere  into  a number  of  layers.  In  the 
CSFM,  the  variables  <t>,  £ and  Dare  defined  at  the  levels  while  T \ y and  W are  defined  between 
the  levels.  Fig.  (la).  The  finite  difference  form  of  the  equations  in  the  vertical  direction  using 
this  scheme  does  not  conserve  total  energy.  For  short  range  forecasts  (1-2  days)  energy  con- 
servation is  not  critical  but  for  medium  and  long  range  forecasts  (3-10  days)  the  forecast  model 
must  conserve  energy  in  order  to  retain  any  skill.  In  order  to  conserve  the  total  energy,  we 
define  the  variables  </>,  f , D and  T at  the  levels  and  y and  W between  the  levels  Fig.  (lb). 

Figure  la  shows  the  vertical  differencing  scheme  used  in  the  original  CSFM.  The 
modified  scheme  is  shown  in  Figure  lb.  Although  the  differences  in  the  geometry  of  the  two 
schemes  appear  slight,  the  modifications  to  the  model  are  extensive  since  the  vertical 
differencing  scheme  plays  an  important  role  in  the  semi-implicit  algorithm  used  by  the  CSFM, 
as  well  as  in  calculation  of  the  non-linear  terms. 

The  equations  solved  by  the  CSFM  are  Equations  (37)  - (42)  in  Daley,  et  a!.,  (1976). 
These  equations  are 
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-a  ~2  1(1  + 1 )/>,"'  = {a  (A  — <4 ) 

- a2V  2£)/", 

(2) 

$2pm 

+ Ry'W',"  = R{a(UT',  VT) 

oval 

- w. 

(3) 

a i*7" 

— ^ + DI"  = { — G)/", 
a<r 

(4) 

a 

~ — ^.7  = o, 
at  *' 

(5) 

<r  M»/" 

T’/H  U ' 

' R dv  ' 

(6) 

where 

rr'2  2tt 

\f\»<  =-L_  I f (T,  I)  Y!"  (A,  a)  cos  Odkdti. 

2tt  yW2Jo  (7) 


and 


I ■ 

F,r  = f FdiT , F = / 


In  the  equations  above  we  use  the  following  definitions  for  the  non-linear  terms  which  appear 
on  the  right  hand  sides  of  Eq.  (1  - 6) 


a (X,  Y) 


1 


cos  2fl 


bx  , a BY 
M + cos"m‘ 


, where  9 = latitude,  <t>  = longitude 


A = (£+/)  U + tr  f-  + 

0<r  a 


2 C0S^  "C°SW  * 


b = d + /)  v - _'^ylf+cosW 

OCT  q (j\ 


G = 
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cos 2 9 
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£ (t/2  + V1) 

2 cos 2 0 

ir  « Ur  - 1)  (G  + D)  + G1’  + D ", 

Bt  = T’D  + y 'cr  - (G  + D)  + ~ G + Ht. 

Lp  cp 


and 


Bs  = SD  — tr 

0(r 


bt] 

GUTd) 


X 


I—  + G — G — D 


+ Ht  - H.. 


Equations  1 and  2 are  the  vorticity  and  divergence  equations  respectively.  Equation  (3)  is  a 
modified  form  of  the  thermodynamic  equation,  using  the  variable  P =<j>  + RT'q.  Equations 
(4,5)  are  forms  of  the  continuity  and  surface  pressure  tendency  equations  respectively.  The  hy- 
drostatic equation  is  given  by  equation  (6).  The  definitions  of  the  symbols  used  are 


/ 

V 

{ 

D 

T 

<7 


■ Coriolis  parameter, 

* horizontal  vector  wind  [with  components  (U,  K)] 
•vertical  component  of  vorticity  -=  k ■ V x V, 

■ horizontal  divergence  = V • f', 

= the  absolute  temperature  (°K) 

’ ), 


■■  static  stability 


RT 


<> 


dT 
d(T  r 


<r  = vertical  motion  in  sigma  coordinates 

“ (<r  — 1 ) (D  + V ■ Vq)  + D,r  + V,r  ■ Vq 
= geopotential  height, 

P = the  horizontal  frictional  force  per  unit  mass, 

Ht  =the  diabatic  heating. 
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R is  the  gas  constant  for  dry  air, 

C is  the  specific  heat  of  dry  air  at  constant  pressure. 

Special  variables  are  defined  by 

P = <t>  + RT'q 
W = ,r  - ,r  (G  + D) 
and 

W\  = W (<r  = 1 ) (G  + D). 

The  ( )*  notation  indicates  a horizontal  mean  and  ( ) is  the  deviation  from  that  mean.  Thus 
T = T*  + T.  The  ( )/"  indicates  the  coefficient  of  a spherical  harmonic  >'/"  defined 

Yj"  (KM)  = v/"  (sin  9)e:mK 

where  x"'  are  the  associated  Legendre  functions  of  the  first  kind  of  order  (/,/»).  m is  the  east- 
west  (zonal)  wave  number,  / is  the  degree  of  the  Legendre  function,  K is  longitude  and  H is  la- 
titude. The  expansion  is  defined  by 

j 1 «|  +./ 

(F)  = £ X (r)i"  Yi"- 

in  - -J  I =* | w| 

This  assumes  rhomboidal  truncation.  As  long  as  n "sufficient"  number  of  harmonics  are  re- 
tained, there  does  not  appear  to  be  any  advantage  of  using  the  triangular  truncation  scheme 


I I 

/ =u  t/  - - 


over  the  computationally  more  efficient  rhomboidal  scheme.  The  vertical  coordi- 
nate is  i r — i>/ps  where  is  surface  pressure  and  />  is  pressure. 


III.  DIFFERENCING  FOR  ENERGY  CONSERVING  VERTICAL  GRID 


We  will  use  the  following  definitions  for  weighted  variables  and  difference  operators 
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[A„]  = (/<„  + , + A„)/2 
8 (A„)  = (<4„  + , - A„) 

= ln  (<r,l  + \/<'rn) 

<1„  = In  Urn  + i /«•„) 

and  A/  is  the  total  number  of  levels  (see  Figure  1)  in  the  model.  The  (~)  denotes  the  dashed 
lines  in  Fig.  (1),  which  represent  layers.  The  spacing  between  the  levels  is  on  a logorilhmic 
scale  so  that  8 (<r  ) need  not  be  a constant. 


The  hydrostatic  Equation  (6)  becomes 


8 (<l>„) Rd„  [r„] 


(8) 


where  we  have  dropped  ( )/"  notation  in  this  and  all  of  what  follows.  Thus  these  equations 
apply  to  each  spectral  coefficient.  When  the  non-linear  terms  are  to  be  formulated,  an  inverse 
transform  to  a real  Gaussian  grid  must  be  performed.  At  the  surface  we  impose  an  artificial 
boundary  layer  defining  a lapse  rate  at  the  lowest  level: 


dT 

dl> 


£. 

a 


(9) 


where  F is  the  lapse  rate.  In  the  version  of  the  model  discussed  here,  I'  is  held  at  6°/km;  later 
versions  of  the  model  will  contain  explicit  boundary  layer  formulations  which  will  generate  I 
Using  Eq.  (9)  we  define  a surface  temperature  7\ 

l K 17# 


F,  = 7\ 


1 


= CrTs, 


Equations  (8)  and  (9)  then  define  a matrix  equation  of  the  form 


M,  <t>  + 4»v/rfv  8 v y Mn  T 


where 


(10) 
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; -i  id,,  i = / 

+ 1 Id,  ,j  =i+l 
io  , otherwise 


1 J = i 
\,j  = i + 1 
0.  otherwise 


with 


(W//).V./V  = 1 + CJ 

In  the  above  equation  both  T and  <b  are  vectors  of  length  N,  and  Ts  and  <t\,  the  surface  values, 
are  carried  separately.  The  delta  notation,  fi  \ is  used  to  indicate  that  the  term  will  be 

included  only  with  the  equation  for  Ty.  In  order  to  compute  T from  4>  we  use  Eq.  (10)  to  ob- 
tain 


7 [M„~[  M i <1>  + M„  1 &N4>Jds] 

A 


= - lM,,d>  + M,T'  aN*JdN\ 


The  finite  difference  form  for  y,  the  static  stability,  becomes 

1 


y,<  = 


JL,rl_iW 

r " d 

p u n 


At  the  surface  we  define  ys  by  using  Eq.  (9) 


Ys 


= C, 


(II) 


(12) 


(13) 


We  can  rewrite  Eqs.  (12,  13)  in  the  following  form 

y = My  T 


where  the  vectors  are 
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yj,  = (>i.>2  ••'y,\-|.rs'0) 

T,!  = T2 7\  , tn.  /;) 


and  the  matrix  My  is 


+ 4-  *'or  j = / 


-i ^ 7-  for  /'  = / + 1 


CT  — — for  / = S and  i — N + 1 

C,,  K 

0.  otherwise 


There  is  no  relation  between  7n  and  7,  analogous  to  Eq.  (9).  In  addition,  since  <r0  =0,  we 
can  not  differentiate  with  respect  to  <r  at  the  top  boundary  in  our  log  Ur)  coordinate  system. 
Thus,  for  the  top  boundary,  we  will  use  a simple  deviative  with  respect  to  <r  (see  below),  rather 

than  — 77 * 1/ln  (o-n+,/a„). 

CT  0(T 

At  this  point  we  describe  the  procedure  used  for  dry  convective  adjustment.  If  the  lapse 
rale  exceeds  the  dry  adiabatic  lapse  rate  (y  < 0),  the  lapse  rate  is  adjusted  to  be  adiabatic  in 
such  a way  that  the  total  potential  energy  of  the  column  is  conserved.  We  define  the  quantity 
(Manabe  et  al.) 

n 

PE  - f 7 C„  (hr 

•t  (14) 

which  is  proportional  to  the  potential  energy  of  a column,  and  let  the  last  element  of  the  y 
vector  contain  PE.  We  then  modify  M by  adding  elements 


^vl-.N+l  ~ ^,T  1 


to  the  last  column. 
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In  the  case  of  convective  adjustment  we  can  then  determine  a new  temperature  profile 
consistant  with  Equation  (14)  by  setting  elements  which  are  less  than  zero  to  zero  and  mul- 
tiplying by  M~x  to  obtain  T.  This  procedure  has  the  affect  of  adjusting  the  temperature 
profile  to  obtain  stability  while  conserving  potential  energy. 


We  now  derive  an  equation  for  the  vertical  velocity.  Starting  with  Eq.  (4)  which  is  given 
in  finite  difference  as 


Using  the  boundary  conditions  on  W: 


( Dn  + G„). 


^0  “0 


we  can  write  the  matrix  equation 


Ws (G  + D) 


W = (D  + G)er 


where 


— 1M,  _]  / " j and  i > 1 
+ 1/A,  _i , i = j + 1 and  i > 1 
'J  ~ — 1 A?,,  / =1,7  =1 
0,  otherwise 

WT  = (Wv  W2 WN_X,  Ws) 


(D  + G)  T = (Z>,  + Gj , D2  + G2,  •••,£>„+  Gn). 

To  develop  the  correct  form  for  the  geopotential  we  begin  with  the  thermodynamic  equa- 
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Since  & — W + & (G  + D)  we  define  the  quantities  >V  at  the  intermediate  levels.  Thus  the 
finite  difference  form  for  Eq.  (16)  can  be  written  as 


— M2  W = -a(UT‘,  m + Bt 


where  we  define  the  matrix  operator  A/2  as 


M2  - Ma  + Mb 


y 'll  for  j - /,  / < AT,  (>A,  = ys) 
(wJ,j  = y,’/2  for  j «/  -1./  < A' 


(0  otherwise 


\ KT  i 

**  8J.\  J <*!  -i  + >,  <?,)| 


Now  we  use  the  definition  of  P = <J>  + together  with  Eq.  (10) 


to  yield 


T = - A/, 


, . 2 “ -i  8 

•t  + — Mu  1 ; — 


where 


T - - A/Jp  - RqT* ] 


2 " , *,#' 


Substituting  this  equation  into  Equation  (17)  and  noting  that  - 

bt 


0 and 


^ - tf'  we 
Or  1 we 


] 
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difference  form  of  Eq.  (2)  for  a semi-implicit  integration  becomes 


r\(+\t  i r\(  — Af  p/+Af  _i  pf  — Af 

— + a ~2  (/)(/  + 1)  - 


{■ a(B . - A)  - a2  V2  £}. 


and  Eq.  (20)  for  the  temperature  becomes 


\pt+\t  pi  fl 


D'  + M + £)'-At 


2Ar 


{a  ( nT , VT)  - Bt  - Af,  G)  + Afp 


pt  — Af 


n'  +Ar  Qf  ~Af 

The  use  of  the  notation  0'  = simplifies  the  notation  and  allows  us  to  rewrite 

these  two  equations  as 

D'  + A/ a ~2/0  + 1)  P'  =D'~*'  + Ar{a(fl,  - A)  - a2  V2£) 


P'  + MM~X  Af,  D'  = P ,_A'  + M M~x  (a  (UT',  VT)  - BT ) - A t Af  -1  Af,  G. 


By  substituting  (21)  into  (22)  and  defining  Af  = MP  1 Af,  we  obtain 


[1  + (A i)2a  ~2  I (/  + 1 ) Af]  P'  = P 


l _ pi  -A i 


+ A t M.  -1{a  (UT,  VT')  - Bt | 


+ At  Af  { - G - D'_a'  - At  (a(B,  -A)  - fl2V2  £}} 


Equations  (1,  4,  S,  21  and  23)  form  a closed  set. 


IV.  COMPARISON  OF  MODELS 


A five  level  version  of  the  model  with  two  horizontal  resolutions,  namely  10  and  20 


waves,  has  been  integrated  for  three  days.  Figure  (2)  shows  the  500  mb  temperature  forecast 

12 


for  ihe  Noriheast  Uniled  Slates  using  both  models  as  well  as  observed  dala  for  verification. 
This  location  was  picked  at  random;  other  locations  yield  similar  results.  The  new  model  clear- 
ly shows  an  increase  in  skill  for  one  and  two  day  temperature  forcasts  over  the  previous  model. 


Beyond  two  days  both  models  deviate  considerably  from  observations,  the  primary  problem  be- 
ing lack  of  moisture  and  treatment  of  the  upper  boundary  condition 

In  order  to  illustrate  further  some  of  the  dynamics  of  the  model,  we  show  the  zonal  har- 
monic structure  at  45°N  lattitude  for  each  level  in  Fig.  (3).  Examination  of  the  figures  indi- 
cates that  the  forecast  of  the  planetary  scale  waves  (A/  =1  - 3)  is  improved  as  are  the  synop- 
tic disturbances  (M  —5  — 8)  near  the  surface.  The  improvement  in  the  surface  forecast  is 
probably  a direct  result  of  adjustments  in  the  lower  boundary  made  in  the  modified  model.  VVc 
expect  that  even  better  results  could  be  obtained  with  the  incorporation  ol  a complete  boun- 
dary layer  model. 

For  tests  on  extended  range  forecasts,  we  find  that  energy  lends  to  accumulate  in  the 
upper  levels  of  the  model  for  large  zonal  wavenumber  for  forcasts  longer  than  three  days.  This 
severly  degrades  medium  range  forecasts.  We  attribute  this  efTect  to  the  use  of  a simple  pres- 
sure difference  at  the  upper  boundary  region  rather  than  the  logrithmic  derivatives  used  else- 
where. 
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Fig.  1 - (a)  The  grid  system  used  in  the  original  CSFM  and  (b)  the  grid  system  used  in  the  modified  version. 


HOUR +6  +12  +18  +6  +12  +18  +6  +12  +18 

DATE  (NOV  1969) 

Fig.  2 - Temperature  history  for  North  Fast  United  States,  showing  CARP  data 
[November  4-9,  1969|,  the  predictions  using  the  new  model  (-)  and  predictions 
using  the  old  model  ( — ). 
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U3AV1/13A31 

cvj  cvj  to  ro  sj-  V in  "in 
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g.  3 - A comparison  of  the  amplitudes  of  the  Fourier  components  of  temperature  for  the  latitude  45  in  the 
northern  hemisphere:  a)  data  at  day  4;  b)  data  at  day  5;  c)  old  model  at  day  5;  d)  new  model  at  day  5. 


Appendix  1 


Listing  of  the  Spectral  Forecast  Model 

1 . Block  Diagram  of  the  Model 

2.  Index  to  Subroutines 


3.  Listing  of  the  Computer  Code 


MOUNTAINS  (83) 


CONTROL  (5) 


GARP  DATA  (81)  [NOV.  4-9, 1969 

.SPECTRAL  COORDINATES. 


GARPIN 

TT 

"garptape"  (42) 

I 


RPTS  6 

. X 

"sigmet"  (52) 

I 


RSPW6 


f 


PRECIPITATION  (74) 
(IF  WET) 


"met"  (72) 

1 r 


(5)  CONTROL  CARDS 

(PRESSURE  GRID) 


CONVERTS  FROM  PRESSURE 
CO-ORDINATES  TO 
SIGMA  IN  VERTICAL 
(P  ^P/Ps) 

MODELING  PROGRAM 
(IN  o-  CO-ORDINATES) 


(INITIAL  PRESSURE  HEIGHTS) 
CONVERTS  TO  PRESSURE 


CONTROL  (5) 


RSTP6 

MAPS 


"Airmet"  (82)  CAN  BE  USED  AS 

"Sigmet"  (52)  FOR  RESTARTS 

Tig.  4 - Block  diagram  of  the  interaction  of  the  form  modules  of  the  model  and  the  history  tapes  which  they  generate. 


l-ii 


MEMBER 

ABCII 

1 

ALPAS2 

2 

ALPDR2 

3 

ALPNM2 

4 

BPFT 

5 

CFVAL2 

6 

CHIC 

7 

CONADJ 

8 

CONTOR 

11 

CRIRLH 

14 

DELEK 

15 

DELTAQ 

17 

DEWPNT 

18 

DFDS 

19 

DFDSM 

20 

DFDSQD 

21 

DIMCAL 

22 

EGRAFS 

23 

EKLAT 

24 

ENERD 

25 

ENOUT 

28 

EPSIL2 

30 

FASP2 

31 

FCONW2 

32 

FFGFW2 

40 

FFWFG2 

42 

FOUR2 

44 

FPAK 

46 

GAM SAT 

47 

GARPIN 

48 

GARP6* 

53 

GAUSSG 

55 

GGASP2 

57 

GWAQD2 

59 

GZFBP 

61 

HTVOCP 

62 

INPOC 

63 

INPIGG 

65 

INS 

67 

INVRSI 

69 

LLFXY 

70 

LNER 

71 

MATMLT 

71 

MHANLW 

72 

MHEXPW 

75 

MTXINV 

77 

NEWBP 

79 

NEWC 

80 

♦Indicates  a control  program  (see  block  diagram) 


l-iii 


MEMBER 


NEWES 

81 

NEWP 

82 

NEWPS 

83 

ORDLEG 

84 

PBLMAT 

85 

PCOF2 

87 

PCPADJ 

88 

PERM 

90 

PHSCON 

91 

POUT 

92 

POUTF 

94 

PTS6 

96 

QDAW2 

101 

RCOM 

103 

RHSSI 

104 

RPTS6* 

105 

RSGGP 

106 

RSPW6* 

108 

RSTP6* 

110 

SAVPCP 

112 

SAVPRG 

113 

SCOF2 

115 

SEAFLX 

116 

SECOND 

117 

SETL 

118 

SETOLD 

119 

SETZT 

120 

SFDRAG 

121 

SGTPRE 

122 

SMOV2 

124 

SPAF2 

125 

SPAGG2 

126 

SPAPS2 

128 

SPCHUM 

131 

SPLAB 

132 

SPLAT2 

134 

SPMCON 

136 

SPW6 

138 

STBADJ 

145 

STMCAL 

147 

STP6 

148 

TERPI 

153 

TERP2 

155 

TERP2E 

157 

TFBP 

159 

TFGZ 

160 

TMCAL 

161 

TSIG 

162 

l-iv 


mumuuiv 


VEMFLX 

163 

VRTIGW 

164 

WETCON 

168 

WSGGP 

170 

SUBROUTINE  ABC  X I COT,  A , ILEV,  IP) 

PARAMETER  11*5,  I l«ILt 1 , IRj*25,  IRM«2*JRSM 

THIS  SUBROUTINE  CALCULATES  THE  VERTICAL  DIFFERENCE  MATRIX 
FOR  THE  IMPLICIT  TIME  STEP  CALCULATION  OF  PEE.  SINCE  THE  MATRIX 
OEPENOS  ON  "DT",  IT  HAS  TO  be  called  each  TIME  dt  IS  changed, 
NAMELY  AT  THE  BEGINNING  (CTeDEFT/2)  AND  AT  THE  SECOND  TIME 
STEP  WHEN  (DTsDEET) 

PEECT)  X 0+<DT/A)**2*L(LTl)*M)  x RIGHT  HAND  SIDE 

mi  s the  term  in  brackets  for  each  value  of  l (the  wave  number) 

MP I s INVERSE  OF  EACH  Ml  SO  IS  DIMENSIONED  HP  I f ILE V , ILE V , I RM  ) 

Ml  IS  USED  SOLEY  AS  A SCRATCH  M AT  I RX 

REAL  mi ,mji fMIIMl ,M1 ,M2, MP,MPM1 ,M,MW,MPI ,M2M1 

COMMON  / NEWHAT  / MICIL,IL),MIICIL,IL)»HIIM1(IL,IL)#M1(IL,IL)* 

* Me  CIL,  IL),  HP  (IL,IU,MPM1  C I L , I L ) , M CIL , IL ) , 

* MWCIL,IL),HPI(IL,IL,IRM),M2M1(IL,IL) 


IR2Pls2*IRtl 
DTS  = (DT/A)**2 
DO  11  L = 1,  IR2P1 
FNS»FLOATCCL-l)*L)  * DTS 

DO  10  J s 1,  ILEV 
DO  10  I * 1,  ILEV 

10  M 1 ( I , J ) = FNS  * M ( I , J ) 

DO  12  I = 1,  ILEV 

12  M1(I, I)  <*  Hid, I)  ♦ 1. 

11  CALL  MTXINV  (HPI(1,1,L),  Ml,  ILEV) 


RETURN 

END 


SUBROUTINE  ALPaS2(ALP#LALP#L*#WRKS) 


* ALP (LALP#  LM)  CAN  CONTAIN  THE  LEGENDRE  POLYNOMIALS  CALCULATED 

* ev  SUBROUTINE  ALPMN2#  OR  THEIR  N-S  DERIVATIVES  CALCULATED 

* BT  SUBROUTINE  ALPDR2. 

* THE  SYMMETRIC  AND  ANTISYMMETRIC  VALUES  IN  EACH  ROW  OF  ALP 

* ARE  ORIGINALLY  INTERLEAVED.  E.G.  ROW  1 s (0# 1 , 2, 3# . . ,L ALP ) . 

* This  SUBROUTINE  SEPARATES  EACH  ROW  INTO  TWO  PaRTS. 

* E.G,  ROW  l s (0,2,«...LALP/2,  t,3,5...LALP  ). 

* WRKS  IS  AM  SCM  WORK  FIELD  OF  LALP  WORDS, 

* WARNING  - LALP  MUST  BE  EVEN. 

DIMENSION  ALP (LALP#  1 ) 

DIMENSION  WRKS  Cl) 

LALPHsLALP/2 

lalphi«lalphm 

DO  3o  Ms  1 , LM 

* TRANSFER  ONE  ROW  OF  ALP  TO  WRKS. 

DO  20  Nsl.LALP 
20  WRKS(N)«AUP(N,M) 

* put  the  symmetric  values  in  words  i to  lalp/2  of  alp. 

NSYHs-l 

DO  22  N«1,LALPH 
NSYHsNSYH+2 

22  ALP(N,M)aWRKS(NSYH) 

* plt  the  antisymmetric  values  in  words  lalp/2+i  to  lalp. 
NASH=0 

DO  2U  NaL ALpW  1 # L ALp 
NASHaNASM+2 

?4  ALP(N,M)eWRKS(NASM) 

CONTINUE 


30 


RETURN 

END 


SUBROUTINE  ALPDP2(C4LP, alp, L ALP, LB, EPS  I) 


* CALCULATES  N-S  DERIVATIVES  Or  EACH  ASSOCIATED  LEGENDRE  POLYNOMIAL 

* DALP(L*LP,LH)  WILL  CONTAIN  N-S  DERIVATIVE  Or  ALP. 

* ALP(LALP#LM)  CONTAINS  LEGENDRE  POLYNOMIALS  EOR  ONE  LATITUDE. 

* EPSI <LALP,LM)  CONTAINS  PREVIOUSLY  CALCULATED  CONSTANTS. 

* WARNING  • LALP  MUST  PE  EVEN. 

* • LAST  ELEMFMT  OF  EACH  ROW  IS  SET  TO  ZERO. 

DIMENSION  DALP (L *LP# ALP (LALP, l),EPSI (LALP, 1) 

lalpm=lalp-i 

DO  30  Ms l , lm 

CO  20  n=1,LALPm 
FNSsFL0AT(m*n-2) 

ALPlL*isO, 

IF(N.GT.l)  ALPILMsALP(N-1#M) 

CALPCJ,m}s(FNS»i.)*ePSI(N,M)«ALPILM  - FnS*EPSI(N*1,m)*ALP(N41,M) 

20  CONTINUE 

30  DALP(LALp#m)=0, 

RETURN 

END 


SUBROUTINE  ALPnM2(ALP,LALP,LR,SINlAT,ePSI) 

* P L T s LEGENDRE  POLYNOMIALS  IN  AlP(LALP,LM)  FOR  ONE  LATITUDE. 

* SINLAT  IS  THE  SINE  OF  THE  REQUIRED  LATITUDE. 

* epsi  is  a field  of  constants  the  same  size  as  alp. 

* THF  SYMMETRIC  and  aN T I S YMMF TR I c VALUES  IN  ALP  ARE  INTERLEAVED 

* IN  EACH  ROW.  e.G.  ROW  l ■ ( 0,1, 2, 3. ...LALP  ). 

« warning  - LALP  MUST  BE  EVEN,  ITS  MINIMUM  VALUE  IS  4, 

DIMENSION  ALP  CL  ALP,  n»  EPS  I (LALP  # n 

CCS2si,-SINLAT**2 
PPOC«l  . 

A * 1 , 
eso. 

* LOOP  TO  COVERS  LONGITUDINAL  WAVE  NUMBERS  0 TO  LM-l. 

CO  30  m- 1 , LM 
FMsFLOAT(M-l ) 

IF(M.EQ.l)  GO  TO  12 
AsA  + 2. 
e=B  + 2. 

PR8CsPRQD*C0S2«A/P 

* compute  the  fipst  two  elements  of  the  Row, 

12  ALP(1,m)sSQRT(.5*pr;D) 

ALPC2,M)xSCRTC2.*FM+3. )ASINLAT*ALPf 1,m; 

* NO  COMPUTE  ELEMENTS  3 To  L R IN’  THE  ROW  IN  PAIRS. 

DO  20  N»3,LALP,2 

ALP(N,M)s(SINLaTaALP (N»1,M)  * EPSI(N-1,M)*AlP(N.2,M))  / EPSI(K,n 

ALP(N  + 1,M)=(SINLATaALP(N,M)  • EPSI (N,M)*AlP  (N-l  ) / EPSI(N41,mi 

20  CONTINUE 

30  CONTINUE 

RETURN 

END 


I 
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SUBROUTINE  BPFT(PEE*T,PSrPHlS,LA,LRS,lM,lLEV/TM£4NfRGAS,3F> 

* CALCULATES  pee  fr ON  T(PS,PHIS,TMEAN  BY  INTEGRATING  UP  PROM  the  g 


1 


* IF  MODEL  IS  HEMISPHERIC  PEE,T  ARE  SYMMETRIC. 

* EACH  LEVEL  IS  DIMENSIONED  (LRS,LM). 

* EACH  LEVEL  IS  SEPARATED  BY  LA  COMPLEX  WORDS. 

* PEE  AND  T MAY  PE  EGl I V ALENCED , 

COMPLEX  T(LAi  t),PEE(LA,|},PHlS(n,PSm 
DIMENSION  TMEAN (l).SF(l) 

COMPLEX  psurf 

ILEVP  s 1LE V ♦ i 
ILEVM  a ILEV  - 1 

00  3n  Ms i # LM 
MRs(M.1)*LRS 
00  30  N=1,LRS 
ILsmr+n 

PSURF  s RGAS  * TmeaN(ILEVP)  * PS(IL) 

IF (IL.GT.l)  PSURF  s PSURF  4 PHI5CIL) 

PEE ( IL# ILEV)  s PSURF 

1 + SF (ILEV)  * 0.5  * RGAS  * { T ( IL , ILEVP ) *T  ( IL , ILEV  ) ) 

2 - RGAS  * (TMEAN(ILEVP)-TMEAN(ILEV))  * P S C I L ) 

CO  10  I H I a 1,  ILEVM 

IH  = ILEV  - I H I 

PEE (IL» IH)  s PEE(IL#IH+1) 

PEECIL.IH)  = PEE(IL»IHJ  ♦ SF (IH)*0,5*RGAS* (T (IL , IM+1  )*T (IL, IH) ) 
10  pEE (IL» IH)  a PEE(IL,IW)  • RG AS*PS ( I L ) * (THE  AN ( I H+ 1 ) -TMp AN  ( IH )) 

30  CONTINUE 

RETLRN 

END 


I 
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SUBROUTINE  CF VAL2 ( VAL ,CFC , NW , RLON ) 

* EVALUATES  COMPLEX  FOURIER  SERIES  IN  CFC  TO  WAVE  NUMBER  NW 

* * T POINT  RLON  (RADIANS), 

* C ACTUALLY  CONTAINS  THE  POSITIVE  HALF  OF  THE  COMPLETE 

* COMPLEX  SFRIES.  THE  mean  IS  IN  CFC(l), 

DIMENSION  CFC  ( 1 ) 


NWPlsNWfl 

val«o. 

CO  20  HP=2,NWP1 


MMsHP+MP 

FMX»RLON*FLOAT(MP-1 ) 

SINHXsSIN(FMX) 

COSMXsCOS(FMX) 

VALsVAL+COSMX*CFC (MH-1)-SINHX*CFC (MM) 


20  CONTINUE 

VAL*2.*VAL*CFC(I) 


RETURN 

END 


I - 
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FUNCTION  CHIC(H,FC) 


FOR  H BETWEEN  MC  AND  1,0 
*CHIC*  IS  * LINEAR  FUNCTION  OF  H 

IF(W.GE.l.)  GO  TO  1 

CHIC  a (H-HC)/(l,-K) 

RETURN 

1 CHIC  » 1.0 

return 

END 
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mill, 


..... 


SUBROUTINE  CONArJCT,Q,Pcp#PRESSG,W,P,$T,NUPS,NSUPS»IlEVM#D|l.) 


* performs  convective  adjustment 

* COMPUTES  BOTH  LARGE  AND  SMALL  SCALE  PRECIPITATION 

* COMPUTES  EVAPORATION  OF  FALLING  PPEC IP  I T A T I ON 

common/acjpcp/hc,hf,hm, a*»pepth,lheat,moiadj,moiflx 
DIMENSION  T(n#Qm»PCl)#ST(ILEVM,n 
DIMENSION  DEL  ( U 
LOGICAL  ADJ,WLT 


* GAM,GAC  stability  factor  AND  ITS  CRITICAL  VALUE 

* hs  critical  saturation  relative  humidity 

* DTF  TEMPERaTLRE  CHANGE  caused  ry  A CONVFCTIVE  ADJUSTMENT 

* OTH  TEMPERATURE  CHANGE  CAUSED  BY  A RELEASE  OF  LATENT  HEAT 

* DGF  MOISTURE  CHANGE  CAUSED  BY  A CONVECTIVE  ADJUSTMENT 

* DCR  MOISTURE  EQUIVALENT  TO  PRECIPITATION  AMOUNT 

* DC  I , DQ J SATURATION  DEFICITS 

PCP*0.0 

iTEPaO 

PCPCH«PRESSG*DEPTH 
HETe. FALSE. 

5 ADJs. FALSE. 

ITERsITERM 
DQR«  0 , 0 

DO  50  IslfILEVM 

J * I ♦ 1 
GACsO.O 
DTFsO, 0 
D TH«  0 . 0 
DQFsO.O 
DQHsO.O 


* convective  HEAT  FLUX  * 


* COMPUTE  GaM 

TTsSTd,  1 )*T(I)TSTCI»2)*T(J) 
GAM8TT+ST(I,3)*(T(I)-T(J)) 

* COMPUTE  H 

HsQ(J)/SPCHUM(T(J),P(J)) 

* COMPUTE  HS 

NS#AMIN1(H,1.) 

IF(W.GE.O.O)  go  TO  15 

IF(H.LE.HM.OR.ITER.NE.l)  GO  TO  10 

HSsCRIRLH(HM,H, AA) 

10  IF(H*m0IADJ,LT,HC)  GO  TO  15 


I - 8 


* COMPUTE  GAC 
QST«SPCHUM(TT,P(J)*ST(I,6)) 
GAC«CHIC(H#HC)*GAM$AT(TTfQ$T) 

15  IFCGAM.GE.GAC)  GO  TO  20 

If (GAC. ME. 0.0)  WETs. TRUE. 

DTFaSTCI#4)*CGAC-GAM) 

T(I)sT(I)+0TF*STCI,5) 

T(J)=T(J)iOTF 

***************** 

* MOISTURE  FLUX  * 

20  G5JshS*SPCHUM(T(J),FCJ)) 

DQJsQSJ-Q(J) 

IF(CQJ.GE.O.O)  GO  TO  45 

1F(DTF*MOIFIX.EC.O.O)  GO  TO  30 

GSIsAMAXl (HS,HF)*SPCHLM(T(I) ,P(I)  ) 

DQIsQSI-QCI) 

IF(DQI.LE.O.O)  GO  TO  30 

0GFsAMAx1C0QI/5T(I,5)»00J) 

Q(I)*Q(I)T0QF*STCI,5) 

GCJ)*OCJ)+DQF 

DGJsQSJ-QCJ) 

30  IFCHS.LT. AMInj  (HC.MM))  GO  TO  <15 

* CONVECTIVE  OR  STAPLE  HEATING  BV  CONDENSATION  * 

PQh*dELTAQ(TCJ) ,GSJ,DCJ,hS) 

DGHsLHEAT*(DQH-D0J)4DGJ 

DTHs-HTVOCP(T(J))*DCH*LHEAT 

TCJ)*TCJ)+OTH 

Q(J)«Q( J)+OQH 

************************************** 

* CONVECTIVE  or  STABLE  PRECIPITATION  * 

O^R  » DOR  ♦ DEL ( 1+ 1 ) *cGh 
45  IFC0TF*(DTF-DTH).GT.0.01)  ADJs.TRUE. 

50  CONTINUE 

PCP  * PCP  - dqr*pcpch 

IFCADJ)  GO  TO  5 

IF(ITER.EQ.l)  GO  TO  60 

NUPS*NUPS+1 

IFC^ET)  NSUPSsNSUPS ♦ 1 
60  RETURN 


I 
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SUBROUTINE  CONTOR(0,XV,YQ,NX,NY,NLIN,MCONT,NX1,nX2,NY1,NY2,TITLE, 
•SUBTIT, VARI.RINC.ROR) 

THIS  CONTOUR  ROUTINE  IS  GENERATED  TO  REPLACE  ROBERT'S  ROUTINE 
THE  CONTROL  VARIABLES  ARE  THE  SAME  AS  IS  THE  CALL.  THE  ADDITIONAL 
VARIABLES  FINC  AND  FOR  aRE  USED  IF  THE  USER  WISHES  TO  SPECIFY 
The  ORIGIN  AND  INCREMENT  HIMSELF,  origin  AND  INCREMENT  ARE  PICKED 
IF  FINC  IS  SET  TO  ZERO  . PROGRESSIVE  CHARACTER  SETS  FOR  PLOTTING 
ARE  USED  I NUMBERS  FOR  CONTOURS  GREATER  THAN  ORIGIN, LETTERS 
FOP  PLOTS  LESS  Than  ORIGIN.  CHANGE  the  EXTERNAL  CALL  FOR  VARIOUS 
SITUATIONS! 

RPLOT  . LARGE  PLOT,  DENSE  POINT  FIELD 
IPLOT  - LARGE  PLOT,  SPARSE  POINT  FIELD 

EXTERNAL  RPLOT 
EXTERNAL  IPLOT 
DIMENSION  8 (NX , NY ) 

DIMENSION  XV(NX),YQ(NY),D(100),D1(100),D2(100) 

INTEGER  TITLE (5) , SUBT IT (2 ) , CHAR  1 (10 ) ,CHAR2 ( 1 0 ) , ZERO , TIT (126), COLLAR 

1R, BLANK 

DATA  ZERO/'0**«'/, BLANK/'  ' / , DOLL AR/ ' IS JS ' / 

DATA  CHAR  1 / ' 1 23456789#  '/ 

DATA  CHAR2/ 1 A BCDEFGHIJ  '/ 

F INC«R INC 
FORaROR 
NCONTsMCONT 
DO  SB  J = 2,6 

88  TIT(J)«TITLE(J-1) 

TIT  C7J-D0LLAR 

DETERMING  MAXIMUM  AND  MINIMUM 
NJrNX 

me  iisMAxvAL(om 
I 2sM I nv AL ( 0 ) ♦ 1 
IKlsIl/NS 
IK2* 12/NS 
IJ2«I2-(IK2*NS) 

IJ1«I1-(IK1*NS) 

IK1»IKU1 
IK2* IK2*  1 
FMX*0 ( I J I , IK  1 ) 

FMNiO (IJ2, IK2) 

IF(ABS(FMX-FMN),GT.t.0E-9)  GO  TO  520 
WRITE (6,98456) 

RETURN 

520  CONTINUE 

98458  FORMATC  VALUE  IS  TOO  SMALL  FOR  THIS  PLOTTER') 

IF(FINC.NE.O)  GO  TO  60 

SELECT  CONTOURS 
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98  IF(NC8NT.GT,MC0NT)  NCBNT«MCONT 
4«4L0G10C(FMX-FMN)/NC8NT)*.1505 

1*4 

IF  (4.11.0)1=1-1 
B«I 
C»4-I 

FINC=10.**B 

IF(C.LT..1S05)  G8  T8  9 

FINC=10.**B*1.5 

IF (C. LT. .3010)  G8  T8  9 

F INC* 1 0 , *»B»2 

IF (C. IT. .95 16)  GB  T8  9 

FINC=10.**B»3 

IF (C  ,LT  , .6505)  GB  T8  9 

F INC= 1 0 , **B*5 

IF (C  .LT  , ,8990 ) GB  T8  9 

FINC*10,»*B*7.5 

9 CONTINUE 
I»FNN/FINC 
F 8R» I *F INC 

IF(FMX«FMN.LE.0)F89«0 
60  1 = 1 

RST*-1 

IFCFMN.GT.F8R)  RST«1 
DETERMINE  ORIGIN 
0 (1 )=F8R 

20  IF(D(1).LE.FMN.*ND.C(1)+FINC.GE.FMN)  GB  TB  10 

D(1)=D(1)+FINC*RST 
GO  T8  20 

10  CONTINUE 
1 = 1*1 

IF (I.GT.MCONT+20)  MRITEC6, 955)1 
IF (I,GT,MC0NTt20)  GO  TO  98 

955  FORMATC  NUMBER  BF  CONTOURS  EXCEEDS  MC8NT  ( ' , lb, ' )*UT0M4TIC 
1SC4LING  BEGUN') 

446  FORMXTC  ONLY  ONE  CONTOUR  PL OT TED , RESC 4L I NG  ' ) 

0 ( I )«D ( I-l ) *FINC 
IF(CCI).LT.FMX)  GO  TO  10 
IF(I.LE.2)  WRITEC6.996) 

I F ( I ,LE  . 2 ) GO  TO  98 
NCON*I 

TIT(1)=BL4NK 
C4LL  NOGRID 
REMOVES  GRID 

C4LL  USXUSY(XV(l),XV(NX),.F4LSE.,YQ(l),YQ(NY),.F4L5t.,TIT) 
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0069000 

0065000 

0066000 

0067000 

0068000 

0069000 

0070000 

0071000 

0072000 

0073000 

0074000 

0075000 

0076000 

0077000 

0078000 

0079000 

0080000 

0081C00 

0082000 


PLOT  ORIGIN 


201  11*0 
12  = 0 

DO  11  J=1,NC0N 

IF(ABS(DM)-F0R).LT.1.0E-«*FINC)  GO  TO  11 
IF(CCJ).LT.FOR)  GO  TO  70 
11=11+1 
oicin=DCJ> 

70  IFCDCJJ.GT.FOR)  GO  TO  11 

12=12+1 
D2 ( 12) =D ( J) 

11  CONTINUE 

PLOT  CONTOURS  GREATER  THAN  ORIGIN 

IF(Il.EQ.O)  GO  TO  200 
DO  100  J=  1 » 1 1 
Hs(J-i)+0.1  +1.0E-R 
TIT(l)sCHARl  (J-H+10) 

100  CALL  CNTOUR(0,NJ,XV,1,NX,YO,1,NY,D1 CJ)*IpLOT#TIT) 

200  13=12 

IFd3.LE.0J  GO  TO  300 

PLOT  CONTOURS  LESS  Than  ORIGIN 

DO  101  J=1,I3 
I=I2-J+1 

M=(J-1)*0,1  +1.0F-0 
TIT(1)=CHAR2(J-m*io) 

101  CALL  CNT0UR(0,NJ,XV,l,NX,Y0/l/NY,D2{I)dpL0T,TIT) 

300  TIT(1)=2ER0 

CALL  CNT0UR(0,NJ,XV# 1,NX,YQ, t , N Y , FOR , IpL OT , T I T ) 

HRITE(6,51)  FMX,FHN,FOR,FINC 
K-RITE(6,52)  SUBTIT  (1),  3UBTIT  (2)  »VARI 

51  FORMAT  ( • MAXIMUM=i,G12.4,  ' MIN  IMUMs  • , G 1 2 , <1 , • ORIGIN  (0)  = *,G12.<1 
1,'  INCREMENT«',Gl2,<n 

52  FORMAT  ( • ',2A0,'  = ',G12.3) 

RETURN 

END 
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FUNCTION  C»IRIH(MM,H,AA) 

* computes  *c«irlh*  ,the  critical  saturation  relative  humidity 

IF (h  ,IE  , t . ) OH  a AA*(H-mm)**J 

IF(H,GT.l.)  DH«AA*(2.»HM-H)**3  ♦ H - t. 

CRIRLh*  H - DH 

RETURN 

ENO 


- IB 
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SUBROUTINE  DELEKCCT,LA,LRS,LM,EF, ILH,ILEV, ALP » DELALP, 

1 LALP,KHEH,IR,IUG#N8CSL#WPKS) 

* THE  LAPLACIAN  of  KINETIC  ENERGY  MUST  BE  ADDED  TO  THE 

* DIVERGENCE  TENDENCY  ct.  this  is  actually  a linear  term  and  could 

* BE  DONE  SPECTRALLY,  BUT  IT  IS  PERFORMED  ON  THE  QRIO  TO  SAVE 

* THE  SPACE  IN  CORE  OF  A COMPLEX  SPECTRAL  E FIELD. 

* THE  TERM  IS  COMPUTED  AND  ADDED  TO  CT  THE  NORMAl  WAY  SIMPLY 

* 0Y  CONVERTING  ALP  TO  N*(N+1)*ALP  AND  USING  FASP2. 

* EF(ILGiILAT)  s gbIC  VALUES  OF  <U**2+V**2).  (lLHslLG/2) 

* ALP  » LEGENDRE  POLYNOMIALS. 

* DELAIP  s WORK  FIELD  FOR  N(NM)ALP. 

* NOTE  - IN  The  PROGRAM  DALP  IS  USED  FOR  DELALP  SO  THIS  ROUTINE 

* MUST  BE  CALLED  LAST  IN  THE  LATITUDE  LOOP. 


k 


COMPLEX  CTCLA, l) ,EF (ILH,  1) 

DIMENSION  ALPCLAL  F, l),OELALPCLALP,  1) 


* COMPUTE  N*(N+1)*aLP  IN  DELALP. 

* IF  model  is  hemisphepic  symmetric  values  OF  ALP  ARE  IN 

* the  first  half  of  each  row  in  ALP. 

LRsLALP 

IF(KHEH.NE.O)  LRsLALP/2 

DO  210  He  I , LM 
DO  210  N=1,LP 
NS*H+N-2 

IF(KHEM.NE.O)  NS=NS+(f-l3 
FNS  = FLOAT(NSA(NS+m 
DELALP(N,M)eFNS*ALP(N,M) 

210  CONTINUE 

* convert  grid  values  to  fourier  coefficients. 

* INCLUOf  IN  WflCSi  T HF  FACTOR  .5  IN  ThE  DEFINITION  OF  KE. 

* ADD  OELSQ(KF)  TO  CT. 

CALL  FFWFG2(EF,ILH,EF,IL.G,  IR,  ILG,wRKS,  ILEV) 

HOCSIswoCSL*.5 
IF(KHEH.NE.O)  HOCSIbHCCSL 

00  310  Lb  1 , ILEV 

310  call  FASP2CCT(1,l)*lRS.LM»EF(1,l)#OElALP»L*LP»KoCSI) 

retlrn 

END 


I 
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FUNCTION  OELTAQ(T#QS#Cf!,HS) 


* COMPUTES  THE  MOISTURE  RELEASE  *DELTAQ*  AT  TEMPERATURE  T 

* WHEN  THE  SPECIFIC  HUMIDITY  IS  GREATER  THAN  ITS  CRITICAL  VALLE  QS 

* BY  AN  AMOUNT  DQ  . 

* HS  IS  THE  CRITICAL  RELATIVE  HUMIDITY  TO  WHICH  QS  CORRESPONDS 

* REF.  LANGLOIS,TELLUS  25, 1973,06-S7 

COMM ON/EPS/ A, B, EPS 1/EPS2 

EPHsEPS2/(HS*EPSl ) 

H«HTVOCR(T) 

YsB/(T*T)*CS*(l .♦QS*EPH) 

HYsH*Y 

HZ*HY/(T*(1.+HY)) 

DELTaQ  S OQ/d.+HYI  * ( 1 ,04DQ/Y*HZ*HZ* (B* CQS*EPh+0 .5)-T ) ) 

RETURN 

ENO 


FUNCTION  DEWPNT (Q # P ) 


* COMPUTES  DEW  POINT  TEMPERATURE  *DEWPNT*  USING 

* SPECIFIC  HUMIDITY  C AND  PRESSURE  F(MB) 

* E IS  THE  VAPOR  PRESSURE  RELATED  TO  *DEHPN'T*  0Y 

* E»EXP(A-B/DEWPNT) 

C0MM0N/EPS/A.B.EPS1,EPS2 

E«Q*P/CEPS1+EPS2*Q) 

DEHPNTsB/CA-ALOGCE)) 

RETURN 

END 
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SUBROUTINE  DFDS  (G . F , S #NN, CON  1 , C0N2) 

DIMENSION  G(NN),F(NN)»8(NN) 

* GIVEN  A FUNCTION  f at  NN  UNEVENLY  SPACED  points,  this  routine 

* CALCULATES  ITS  FIRST  DIFFERENCE  G AT  THESE  POINTS, 

* S MUST  CONTAIN  THE  INVERSE  OF  THE  INTERVAL  LENGTHS. 

* BOUNDARY  CONDITIONS  SPECIFIED  BY  COn1,C0N2,  (SEE  BELOW), 

NNMsNN-1 
DO  10  N s 1 , NNM 

10  G(N*1)3S(N)*(F(NM)-F(N)) 

A=GC2) 

DO  20  Ns2 , NNH 

20  G(N)3(S(N)*G(NM>+S(N-1}*G(N))/CS(N)+S(N-1)) 

« BOUNDARIES 

G(l)sC0Nl*A*(l.-C0Nl)*G(2) 

G(NN)sC0N2*G(NN)  +(1 ,-C0N2)*G(NNM) 

RETURN 

END 
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subroutine  dfdsm (G#F,S*NN) 

* GIVEN  * FUNCTION  F AT  NN  UNEVENLY  SPACER  POINTS,  THIS  ROUTINE 

* CALCULATES  ITS  FIRST  DIFFERENCE  G AT  THESE  INTERNAL  POINTS. 

* S MUST  CONTAIN  THE  INVERSE  OF  THE  INTERVAL  LENGTHS. 

DIMENSION  GC1),F(1),3(1) 


NNMsNN-1 
DO  10  N * I , N N M 

10  GCN+l)«S(N)*(F(N+n-F(N)) 

CO  20  Na2,Nf.“ 

20  G(N)*(S(N)*G(NTntSCN-n*G(N))/(S(N)TS(N-in 

RETURN 

END 


SUBROUTINE  DFDSQD (G,F,PR,S#NN) 


THIS  ROUTINE  IS  THE  SAME  AS  DFDS  EXCEPT  THAT  THE  END  DERIVATIVES  A 
FOUND  FROM  DIFFERENTIATING  THE  QUADRATIC  THROUGH  THE  THE  LAST  TH»E 
POINTS  AT  EACH  END. 

CLEARLY  , NN  MUST  BE  GREATER  THAN  2, 

PH  ARE  THE  COORDINATES  OF  THE  DATA  , AND  S ARE  THE  INVERSE  OF  THE 
SIPERATION  - IDENTICAL  TO  S IN  DFqS. 

DIMENSION  GO),F(l),PR(l),S(n 


CALL  DFDSM(G,F,S,NN) 

G ( 1 ) « F(l)*(2*PR(l)-PR(2)-PRC3))/((PR(l)*PR(2))*(PR(!)-PR(3)))  ♦ 

1 F(2)*(PR(i).PR(3))/((PR(2)-PR(l))*(PR(2)-PR(3)))  ♦ 

2 F(3)*(PR(n-PR(2))/((PR(3)-PR(l))*(PR(3)-PR(2))) 

G ( N N ) a F (NN-2 ) * 

1 (PR(NN)-PR(NN-t))/((PR(NN-2)-PR(NN*l))*(PR(NN-2)-PR(NN)))+ 

2 F (NN- 1)  * 

3 <PR(NN)-°R(NN-2))/C(PR(NN-l)-PR(NN-2))*cPR(NN-l)-PR(NN)m 

R F(NN)*(2*PR(NN)-PR{NN-l)-PR(NN-2))  / 

5 C(PR(NN)-PR(NN-2))*(PR(NN)-PR(NN-1) )) 

RETURN 

END 
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SUBROUTINE  DIMCAL(LRS,LRA,LRU#LRV,LALP»LM,LA#LAW#IR#KHEM) 


* COMPUTES  ROW  LENGTHS  AND  DIMENSIONS  FOR  SPECTRAL  ARRAYS 

* given  the  resolution  (iR)  and  the  region  of  integration  (khemj. 

* IF  THE  MODEL  IS  GLOBAL  LRS«LRAsIRa1,  LPU«LRV«LALP»IR*2. 

* IF  THE  MODEL  IS  HEMISPHERIC  ALL  FIELDS  APE  EITHER  SYMMETRIC 

* OR  ANTISYMMETRIC#  AND  THE  ZEROES  ARE  SQUEEZED  OUT. 

* LRS  * ROW  LENGTH  OF  SYMMETRIC  FIELDS 

* lr a = row  length  of  antisymmetric  fields 

* LRU  = ROW  LENGTH  OF  E-W  nIND  COMPONENT  FIELD 

* LRV  « ROW  LENGTH  OF  N-S  WIND  COMPONENT  FIELD 

* LALP  s ROW  LENGTH  OF  LEGENDRE  POLYNOMIALS  (ALP)  AND 

* ASSOCIATED  ARRAYS  (DALP.EPSI). 

* LH  = NUMBER  OF  rows  in  each  field. 

* LAW  ■ SEPARATION  eETWEEN  SUCCESSIVE  LEVELS  OF  WIND  FIELDS, 

* LA  s SEPARATION  BETWEEN  SUCCESSIVE  LEVELS  OF  ALL  OTHER  FIELDS. 

« IF  c RESOLUTION  OF  THE  MODEL. 
a KHEM»0  FOR  GLOBAL#  1 FOR  N HEM,  2 FOR  S HEM. 


LRS=lRAl 

IF(KHEM.NE.O)  LRSsIR/2+1 
LRAaIP*l 

IF (khEM.NE.O)  lRAb(IR+1)/2 
LRUslRS+1 

IF(KHEM.NE.0.AND.M0C(IR,2).EG.0)  LRU=LRS 
LRVsLRAaI 

IF(khEm,nE,i),AkD.moD(iR#2).nE.O)  lRVslR* 
LALP=IRa2 

IF(M0DCIR#2).NE.0)  lalp=lalpai 

LMrIR+J 

LAslRSauM 

law«lru*lm 

RETURN 

END 


L 


I 
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SUBROUTINE  EGRAFSCE TOTS, LTOT, NSPLAT, I GE,IGH,IGQ,IGD) 

* GRAPH  energies, momentum, vorticity, divergence  if  requested. 

* THE  six  levels  of  etot  CONTAIN  NSPLAT  values  of,,. 

* 1)  KINETIC  ENERGY 

* 2)  POTENTIAL  ENERGY 

* 3)  TOTAL  ENERGY 

* <l)  E-W  MOMENTUM 

* 5)  MEAN  square  vorticity 

* 6)  HE AN  SQUARE  DIVERGENCE 

* EACH  IS  A MEAN  VALUE  OF  ALL  THE  LEVELS  IN  THE  MODEL 

* AT  one  TIMESTEP. 

DIMENSION  ETOTS (UTPT , b ) 

IF(NSPLAT.LL.O)  return 

* SUBTRACT  INITIAL  VALUES  of  KE,PE  AND  TE  TO  GET  CHANGES  ONLY. 

DO  20  J = 1 , 3 
EZEROsETOTSCl.J) 

DO  20  1*1, NSPLAT 
ETOTS(I,J)*ETOTSfI,J)-EZERO 
20  CONTINUE 

* now  draw  the  graphs,  each  graph  picks  its  own  scale. 

* GRAPHS  TURNEO  Off  if  IGE,IGM,IGQ,IGD  set  TO  Zero  RESPECTIVEIV. 

* OTHERWISE  THESE  NUMBERS  ACT  AS  THE  GRAPH  INTERVALS, 

CALL  SPLAT2(ET0TS(l,n,LT0T,3,NSPLAT,IGE,0.,0,) 

CALL  SPL*T2(ET8TS(l,«),LT8T,l,NSPL*T,lSM,0.,fl,) 

CALL  SPL AT2 (ETOTS ( l, 5 ), LT0T,1, NSPLAT,  IGQ,0.,0,J 
CALL  SPL AT2(E TOTS (1, 6 ), ltot, 1, nsplat, IGD,0.,0.) 

RETURN 

end 
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SUBROUTINE  EKLAT(T0TK,EG.PRESSG,ILG,ILEV,H0CSI,KHEH) 

* THIS  SUBROUTINE  IS  PURELY  DIAGNOSTIC* 

* THIS  SUBROUTINE  CALCULATES  KINETIC  ENERGY  AT  ILEV  LEVELS 

* IN  TOTK  FOR  LATER  USE  IN  SUBROUTINE  ENERD. 

* IF  ENERD  is  REMOVED  FROM  The  PROGRAM*  EKLAT  CAN  also  Be. 

* EG  a U**2*v**2 

* PRESSG  S SURFACE  PRESSURE 

DIMENSION  EG(ILG*1),PRESSGU)*T0TK(1) 


wXXs.5*WOcSI/FLOaT(ILG5 
IF (KHEM.NE.O)  HXXaHXX+HXX 

DO  20  IKai,ILG 
DO  20  L=  1 , ILEV 

20  TOTK(L)aTOTK(L)+EG{IK,L)*PRESSG(IK)*WXX 


RETLRN 

ENP 


1 


SUBROUTINE  ENERD  (P,C,T,U, PS, PHIS, PRESS, LA, LAN, 

1 LRS,LR*,LRU,Lm»ILEV,KHEH,TmEaN,TMEANh,5F,CS, 

2 TOTK,TOTP,TOTE,TOTH#PSITOT,CHITOT,ETOT) 

1*  THIS  SUBROUTINE  IS  PURELY  DIAGNOSTIC. 

* CALCULATES  ENERGETICS  FOR  SPECTRAL  MULTILEVEL  model. 

* NOTE  - TOTK  HAS  been  CALCULATED  PREVIOUSLY, 

* IF  MODEL  IS  HEMISPHERIC,  p is  antisymmetric. 

* ALL  OTHFR  FIELDS  ARE  SYMMETRIC. 

COMPLEX  P(LA,n,C(LA,n,T(LA,n,U(LAW,|) 

COMPLEX  PSCn,PHIS(l),PRESS(l) 

DIMENSION  TMEAN(l),TMEANH(n,SFU),DS(l),ETOT(6) 

DIMENSION  TOTK(  l),TOTPU>,  TOTE  { 1) , TOTM  (1)  ,PSI  TOT  ( 1 ) , CHI  TOT  (1) 

COMMON /P ARAMS/  WW , TH , A , A SO , G« A V , RG AS ,RGOCP ,RGO ASO, CPRES 

complex  TBAR(15),TT0P,PRXK,PRXP,PRXM 

ILEVMsILEV-1 

SQRT23SQRTt2.0) 

CP0ASQ=3.5*RGAS/ASQ 

PBAR«PPESS(1)/SGRT2 

CON5*ASO/PBAR*0,5 

CONSM3SORT(fl.O/S.O)/3.0«HH 

DO  I IHsl , ILEV 
TOTE(IH)3u.o 
T0TM(IM)S0.0 
TOTP (IM)so.O 
PSITOT (IH)oo.O 
CHITOT (IH)so.O 

1 continue 

* POTENTIAL  ENERGY. 

DO  <10  Msl,LM 
CP  «0  Nsl  ,LRS 
ILs (M« l ) *LRS*N 

TTOP  3 (SF(2)*T(IL.l)  + SF ( 1) «T (IL.2J)/ (SF (l  J4SF  (2)  j 
T TOP  s 1.5*T(IL,1J-0.5*TTOP 
DO  36  IH=1,ILEVM 
36  TBAR(IH)  s T(IL,IH)*CP0ASQ 

7RAR(1)  s TBAR(l)+0.5*TTPP*CPOAS0 
TUAR(ILEV)  s 0.5*T(IL,ILEV)*CPPASQ 
IFCIL.GT.DGO  TO  3T 
DO  38  IN  s t,lLEVM 

38  TBAP(IH)  s TBAP(IH)4TMEANH(IH)*SQRT2*CP0ASG 
TBAR(i)  s TBAR(1)+0.5aTMEAN(1)*SQRT2*CPOASG 
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TBAR(ILEV)  a TBAR(IIEV)+0.5*TMEANH(ILEV)»SQRT2*CPOASQ 
37  CONTINUE 

DO  39  IH  = 1 , ILEV 

39  TBAR(IH)  = TBAR(IH)  ♦ PH  IS C IL ) *FLO AT ( ILE V ) /ASC 
DO  90  I H = 1 # ILEV 

PRXPaTBAR (IH)*C8NJG (PRESS  ( IL ) ) 

PRXPaPRXP»CONJG(PRXP) 

IF(M.EQ.l)  PRXPaPRXP*0.5 
TOTP (IH)=TOTP(IH)+PRXP 
90  CONTINUE 

* MOMENTUM. 

CO  60  l: 1 i ILEV 
DO  60  M*i,LM 
DO  60  Nsl.LRS 

MNs(M-1)*LRU+N 

MXs(M-I)*LPS+N 

prxmsu(mn,l)*conjg(PResscmx)) 

PRX^=PRXM+CONJG(PRXM) 

IP(M.EO.l)  PRXMaPRXM*o.5 
TOTM(L)  = TOTM(i.)tPRKM 
60  CONTINUE 

* SGUARE  DIVERGENCE. 

CO  65  Lai, ILEV 
DO  65  M s 1 , L M 
DO  65  Na 1 , LRA 
MNa(M-l)*LRA+N 

PSISQaP(MN,L)»CON.JG(P(MN,L)) 
ir(M.f.T.l)  PSISGaPSISQtPSISQ 
PSIT0T(L)=PSIT0T(L)+PSIS0 
65  CONTINUE 

* sguare  vorticity. 

do  70  Lai, ILEV 
DO  7«  Mal.LM 
DO  70  Na 1 , LRS 
MNr (M»l )*LRS+N 

CHISGrC (MN,L)*CONJG(C(PN,L)) 

IP(P.GT.l)  CHISCaCHlSG+CHISG 
CHITOT(L)=CHITOT(L)tCMlSQ 
70  CONTINUE 

* COMPUTE  VERTICAL  SUMS  IN  ETOT. 

DO  83  Na 1 , 6 
83  ETOT (N)rn, 

K«3 
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IF (Khem.KE.O)  K a2 
DO  es  IHBI'ILEV 

TOTH (IH)»(T0TM(IH)-C8KSM«PRESS(K) )*C8KS 
TOTK(IM)s  T8TK(IM)*C8KS 
TCTP(IH)*  T8TP(IH)*C0N8 
CHlTeT(IH)«SORT(CHIT8T(IN)«o.5) 

PSITeT(IH)*SORT(PSITOT (IH)*o.5) 

TPTE(IW)s  T9TK(IH)4T0TP(IH) 

ET9T(l)sET8T(n+0S(IH)*T8TK(lH) 

ETPT(2)sETPTt2)fT0TF(IK)/FL84T(lLEV) 

ETpT(a)sETPTC«)fDS(I^)*T"TH(lH) 

ET?T(5)sETCT(5)tDS(IH)*pSIT8T(lH) 

ETeT(6)=ETPT(6)»CStIH)«CHITCT(IH) 

85  C8STINUE 


ET8TC3)sETPT(l)+ET8T(t) 


RETURN 

ent 


I 
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SUBROUTINE  EN0UT(P,C#T,U,PS,PHI5,PRESS,TMEANH,TmEAN,SF*DS, 

l totk,iR,ilev,khem, etots, ltot,nogR,iepR/DIVch) 

* This  SUBROUTINE  IS  PURELY  DIAGNOSTIC. 

* CALCULATES  ENERGETICS  FOR  SPECTRAL  MULTILEVEL  MODEL. 

* prints  diagnostics  and  fills  graph  array  if  requested. 

* NOTE  - TOTK  HAS  BEEN  CALCULATED  PREVIOUSLY. 


PARAMETER  SlLVsi5,SLEV3Q,SLVsio,SILT352,$ILG»6<l,SILTHs26,JIR«20 
complex  p(i),c(i),T(i)'Um 

COMPLEX  PS(1),PHIS(1),PRESS(1) 

DIMENSION  ET0TS(LT0T,6) 

DIMENSION  TMEAN(l),TMEANH(l),SF(n,DS(l).TOTK(l) 

COMMON/ TIMES/  DEET,KOUNT#KSTART,KTOTAl»  IF D IFF 

DIMENSION  TOTP (SILV), TOTE (SILV),T0TM (TIL Vj.PSI Tat (SILV), 
*CHITOT(JILV),ETOT(6) 


NSPLAT=KOUNT-KSTART+l 

call  DIMCAL(LRS,LRA,LRu,LRv,LALP,LM,LA,LAh,IR,KhEM) 
call  ENERD  (P,C,T,U, PS, PHIS, PRESS, LA, LAW, 

1 LRS,LRA,LRL,LM,ILEV,KHEH,TI'EAN,TMEANh,SE,CS, 

2 TOTK, TOTP, TOTE, TO TM,PSITOT#CHITOT,ETOT) 

* etots  holds  the  mean  values  to  fie  graphed  at  the  end  of  the  run. 

* IF  NOgRsO  no  GRAPHS  are  drawn  And  etots  is  not  filled. 

IF  (NOGR.EQ.in  GO  TO  04 
DO  e2  J = 1 , fa 

82  ETOTS(NSPLAT,J)sETOT(J) 

* IEPR  is  the  INTERVAL  aT  Which  The  ENERGIES  aRe  to  be  PRINTED. 

* IF  IEPR=n  NO  PRINTING  is  CONE. 

e«  IF  (IEPR.LE.OJ  GO  TO  8b 

IF(MOD(NSPLAT-l,IEPR).NE.O)  GO  TO  86 
PS00sPS(l)/5QRT(2.) 

PDARaPRESS(l)/SQRT(2.0) 
wRITE(6,60B0)  KOUNT,PSOC,PBAR,FT"T 

WRITE  (6,6082)  (L # TOTK (L ) , TO  TP (L ) , TOTE (L > , YOTM (L ) , PSI TOT  (L ) # 

1 CHITOT(L).L=lf 1LEV) 

* IF  THE  MEAN  DIVERGENCE  EXCEEDS  DIVCH  The  MOCtL  IS  FORCET 

* TO  TERMINATE  BY  SETTING  KOUNT  = MOTAL  ♦ 1. 

* IP  DlVCHsO.  THIS  TEST  IS  NOT  PERFORMED. 

86  IF (CIVCH.GT.O,  .AND.  ETOT (6)  .GT .DIVCH)  K OUNT»K T OT AL ♦ 1 
RETURN 
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6080  F0RHAT(7H0K0UNTa,I<l,10X,llHlN  SF  PRES* , F.  U . 7 , 1 8 X , flHSF  PRESs,El«,7 

1 // 1 2H  T0T4L  K»,E1<|.7,6H  P=,£l<i.7,6H  K*Pa,E10.7, 

2 6H  M0Fs,El<l.7,6H  VORTa , E 1 0 . 7 , 6*  DIV*,El«,7) 

6082  FCRUTUH  ,I5,6E20.7) 

EMO 


SUBROUTINE  EPSI12CEP$I,LALP»LM) 

* CALCULATES  EPSILON (N#M)  = SORT ( (N**2-M**2 ) / (<UN**2  - 1)) 

* FOR  N FROM  0 TO  LALP-1#  AND  M FROM  0 TO  LM-1  IN  EPSI (L*LP*LM ) , 

* EPSILON  IS  A FIELD  OF  CONSTANTS  USED  IN  THE  SPECTRAL  MODELS. 

DIMENSION  EPSI(LALP*n 


DO  20  Msl,LM 

mS=M-1 

Mai 

IF(MS.EQ.O)  N 1 b2 
DO  £0  NsNl.LALP 
NS=MS+N-1 

FNUMsFLOAT (NS**2  - MS**2) 
FDENsFLOAT (4*NS**2  - 1) 

20  EPSI(H,M)BSQPT(rNUM/FCEN) 
EPSI(l,l)sO. 

RETURN 

END 
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SUBROUTINE  F ASP2 C SC # LR » LM,CFC, ALP, L ALP# WEIGHT) 

* CONTRIBUTION  of  COMPLEX  FOURIER  WAVES  IN  CFC  AT  ONE  LATITUDE 

* ADDED  TO  SPECTRAL  COEFF  IN  SC(LR,LM). 

* THIS  SUBROUTINE  IS  CALLED  ONCE  FOR  EACH  GAUSSIAN  LATITUDE. 

* BEFORE  THE  FIRST  CALL  SET  ALL  OF  SC  TO  (O.,0.). 

* IF  SC  IS  GLOBAL,  ROw  1 CONTAINS  WAVES  0, 1 ,2  . . . CL»-» > . 

* IF  sC  IS  SYMMETRIC,  ROW  1 CONTAINS  WAVES  0 , 2 , H . , . 2* (LR- 1 ) . 

* IF  SC  IS  ANTISYMMETRIC#  ROW  l CONTAINS  WAVES  1 # 3#  5 , , ,2* (LR*1 ) ♦ 1 , 

* AIP(LALP,LM)  CONTAINS  LEGENDRE  POLYNOMIALS  FOR  ONE  LATITUDE, 

* ITS  ROWS  MUST  HAVE  THE  SAME  STRUCTURE  AS  THOSE  OF  SC, 

* WEIGHT  IS  THE  GAUSSIAN  WEIGHT  FOR  THAT  LATITUDE. 

COMPLEX  SC(LP,1),CFC(1) 

DIMENSION  ALP(LALP,1) 

* CALCULATE  (WEIGHT*CFC(M)*ALP(N,M))  FOR  EACH  M AND  N, 

DO  20  Ms1,LM 

CFCRs  REAL(CFC(M))*wEIGHT 
CFC  I» AIMAGCCFC(M))* WEIGHT 
DO  20  NbI,LR 

SC(N,M)xSC(N,M)+CMPLX (CFCR*ALP(N,M) ,CFCI*ALP(N,M) ) 

20  CONTINUE 

RETURN 

END 


! 
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SUBROUTINE  FC1NW2(Z,CINT,SCALE,II,LJ,IH, Jw,ll,MM,MTYPE) 

* MAPS  IL  BY  Mm  wincO^  FROM  POINT  (IW,JW)  IN  GRID  Z(LI#LJ) 

* The  CONTINENTAL  OUTLINE  IS  INTERPOLATED  FROM  A 1/20M  scale  grid 

* OF  SIZE  (51,55)  WITH  NORTH  POLE  AT  (26,28), 

* RIGHT  AND  TOP  GRID  POINTS  OMITTED  FOR  STAR  GRIDS  IF  LJ  NEGATIVE. 

* CONTOURS  FROM  0.  IF  cint.gt.o,  FROM  «,5*CINT  if  cint.lt.o 

* MTYPE  e PHS,  6 LINES/INCH)  NEG,  8 LINES/INCH 

* mtvpe  * 0 EXIT  *ITH  NO  MESSAGE 

* MTYPE  s l TO  3 MTYPE  s GRID  DISTANCE  IN  INCHES 

* MTYPE  s 21  TO  <10  ... 

* mTYPEsMaPSCLaMESH,  MESH  CAN  BE  ANY  VALUE  FROM  1 TO  10  EXCEPT  7. 

* MAPSCL  = 20  FOR  1 /2 0 H , 30  FOR  1/30M  (ASSUMING  GRID  DIST  OF  381KM), 
« PRINTS  FOUR  LOWEST  ORDER  DIGITS  OF  SCALED  FIELD 

* EVERY  2*MESH  GRID  POINTS  FROM  (IW,JM). 

« 1/20M  - PRINTED  POINTS  EVERY  1,5  INCHES,  16*ME3H  GRID  SPACES  PER 

* 1/30M  - PRINTED  POINTS  EVERY  l.fl  INCHES,  25aMeSH  GRID  SPACES  PFR 

« ILLEGAL  CALL  GENERATES  MESSAGE  AND  RETURN. 

* map  UNITS  REFER  TO  A COORDINATE  SYSTEM  CORNERED  ON  (IN,  Jim) 

* IN  WHICH  ONE  INCH  EQUALS  1 ««0  UNITS. 

DIMENSION  2(LI,LJ) 

DIMENSION  X(100),Y(100) 

INTEGER  NPRLIN(130),NABCD(8),NLMBER(10) 

DIMENSION  LWB(8,2<<2)  ,LH  1 (256  ),IW2  (256),  LH3  (256),  Lwa  (256), 
*LW5(256),LW6(256),LH7(256),Lwa(l«<l) 

EQUI V ALENCE  (LW8  (1 , i ),  UN  1 (1)),(LWP(  |,  33  ),L«2(in,(LWB(l,65),lh3(l)) 
EQUIVALENCE  (Lwe(l,RT),Lwa(l)), (LNP(1,12R),LW5(i)),(LWF(1,161 ), 

* LW6(1)), (LWB( 1,1 63), 07(1))' (LWB (1,225 ),LN8(i)) 

DATA  NABCD/lH  ,1MA,1H  ,1HB,1H  ,1HC,1H  ,1HD/ 

data  nUmBER/1hO,1h1,1h2,1h3,1Hu,1h‘',1h6,1hT,1h8,1hR/ 

CATA  NBLANK,NPLUS,NMINUS,NSTAR,ND0T/1H  , lHf,  1H-, 1H*, 1H./ 

DATA  NDPC,  NDPL,  NPCL,  INCH,  INCH  AH/ 1 U<l,2a0, 125,  l«u  0,2  loo/ 

* ARRAY  LWfi  CONTAINS  The  CONTINENTAL  outline  COORDINATES  for 

A 242  PRINT  LINES  of  a 1/20m  ScaLE  "aP.  EaCH  PRINTED  LINE  CA^  HAV£ 

* A mAXImUm  OF  8 POINTS,  PACKED  F0UP  TO  A word  In  TWO  SUCCESSIVE 

* WORDS  OF  LWD.  map  SCALES  OTHER  Than  1/2qM  ARE  INTERPOLATED. 


CATA  LM 1 / 
*178,303,  0, 


0,  0, 


0,177, 185, 18R,  198,201,303  , 


*l70,i82,lR2,lR5,203,302,  0,  0,172,180,204,299,  0, 


*171,180,209,297,  0 


0 , 


0,171,179,206,264,272,294, 


0# 

0, 

0, 


*l7o, 177,207,235,  0,266,281 ,290, l 7 0, 1 77, 2 09,230,239, 257, 285, 

*178,222,225,251 ,254, 


*166,179,  0,  0,  0, 

*157,179,  0,  0,  0, 

*153, 174, 1 7 7 , o,  o, 
*152,165,  0,  0,  0, 


0, 

0, 

0, 

0, 

0, 


0,  0,167,174,246,  0,  0,  0,  0, 

0,  0,159,162,179,  0,  0,  0,  0, 

0,  0,155,179,  0,  0,  0,  0,  0, 

0,  0,152,  0,168,171,  0,  0,  0, 

0,  0,149,164,  0,  0,  0,  0*  0, 


0, 

0. 

0, 

0. 

0, 

0, 

0, 

0, 
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0, 

141, 

144, 

164, 

0, 

0/ 

0, 

0,138,  0,  0, 

165,  0,  0, 

0/ 

0, 

135, 

167, 

0, 

0, 

0, 

0, 

0, 

0,132,  0,152, 

155,  0,168, 

0, 

o, 

131, 

149, 

158, 

168, 

0/ 

0, 

0, 

0,129,146,159, 

169,  0,  0, 

9/ 

0, 

126, 

144, 

161, 

170, 

0, 

0, 

0, 

0,127,144,162, 

170,  0,  0, 

0, 

0, 

144, 

164, 

165, 

0, 

0, 

0, 

0, 

0,124,143,  0, 

0 , 0 , 0 , 

0, 

0, 

123, 

143, 

o, 

0, 

0, 

0, 

0, 

0,122,143,  0, 

0 , Of  Of 

0, 

0, 

120, 

143, 

0/ 

0, 

0, 

0, 

0, 

0,120,143,  0, 

Of  Of  0 , 

0, 

0/ 

DATA 

LW2/ 

120, 

143, 

188, 

0, 

0, 

0, 

0, 

0,122,144,185, 

l e 9 , 0,  o, 

0, 

0/ 

122, 

144, 

184, 

189, 

0, 

0, 

0, 

0,144,189,  0, 

0 , 0 , Of 

0, 

0, 

122, 

145, 

183, 

188, 

0, 

0, 

0, 

0,  122, 146, 183, 

168,  Of  Of 

0, 

0, 

122, 

147, 

182, 

187, 

0/ 

0, 

0, 

0,121,149,179, 

186,  0,  0, 

0/ 

0, 

120, 

150, 

164, 

176, 

0,186, 

0, 

0,113,119,153, 

159,167,173, 

186, 

0, 

111* 

117, 

187, 

0, 

0, 

0, 

0, 

0,111,  0,188, 

0 , 0 , 0 , 

0, 

0, 

Ul« 

191, 

0, 

0, 

0, 

0, 

0, 

0,111,192,  0, 

0 , 0 , 0 , 

0, 

0, 

111/ 

193, 

0/ 

0/ 

0/ 

0, 

0, 

0,111,197,  0, 

0 , 0 , 0 , 

0, 

0, 

111, 

198, 

0, 

0, 

0, 

0, 

0, 

0,111,198,  0, 

0 , 0 , Of 

0, 

0, 

1 10, 

198, 

0, 

0, 

0, 

c, 

0, 

0,111,197,  0, 

o 

o 

o 

0, 

0, 

til, 

197, 

0, 

0, 

0/ 

0, 

0, 

0,111,198,  0, 

000 , 0,  0, 

4/ 

0, 

111/ 

199, 

o, 

0, 

0, 

0, 

0, 

0,111,200,  0, 

0 , 0 , Of 

0, 

0, 

111/ 

201  , 

o# 

0, 

0, 

0, 

0, 

0,112,203,  0, 

Of  Of  Of 

0, 

0/ 

113, 

204, 

0, 

0, 

0, 

0, 

0, 

0,113,206,  0, 

Of  Of  Of 

0, 

0, 

113, 

207, 

0, 

0, 

0, 

0, 

0, 

0,113,207,  0, 

Of  0 , 0 , 

0, 

0, 

112, 

209, 

0, 

0, 

0, 

0, 

0, 

0,111,212,215, 

0 , Of  Of 

0, 

0/ 

DATA 

1*3/ 

111/ 

216, 

0, 

0, 

0/ 

0/ 

0, 

0,111,219,  0, 

Of  Of  Of 

4, 

0, 

111/ 

219, 

0, 

0, 

0, 

0, 

0, 

0,111,215,218, 

Of  Of  Of 

0, 

0, 

112, 

212, 

0/ 

0, 

0, 

0, 

0, 

0,113,210,  0, 

0 , o , o , 

0, 

0, 

113, 

210, 

0, 

0, 

0, 

0, 

0, 

0,189,191,210, 

356,359,  0, 

0, 

0, 

113, 

188, 

192, 

213, 

0,349,362,369,113,187,192, 

0,216, 346, 362, 36e, 

119/ 

186, 

192, 

219, 

347, 

371, 

377, 

0,115,186,191, 

344,  0,  0, 

0, 

0, 

117, 

186, 

191, 

341, 

0, 

0, 

0, 

0,119,183,192, 

218,332,335, 

338  , 

0/ 

121/ 

180, 

192, 

215, 

330, 

0, 

0, 

0,122,179,192, 

214,329,  0, 

0, 

0, 

1*7, 

192, 

326, 

0, 

0, 

0, 

0, 

0,126,174,191, 

0,210,326, 

0, 

0, 

126, 

174, 

191, 

203, 

210, 

326, 

0, 

0,127,173,191, 

201,207,324, 

0, 

0, 

128, 

174, 

192, 

200  , 

323, 

0, 

0, 

0,128,174,192, 

200,322,  0, 

0/ 

0, 

129, 

176, 

197, 

321, 

0, 

0, 

0, 

0,130,176,320, 

0 , Of  Of 

0, 

0, 

131, 

179, 

320, 

0, 

0, 

0, 

0, 

0,131,180,204, 

Of  Of  Of 

0, 

0, 

132, 

183, 

220, 

22«, 

319, 

0, 

0, 

0,132,184,218, 

0,225,318, 

0, 

4, 

132, 

186, 

216, 

225, 

3 1 7 , 

0, 

0/ 

0,  29,  31,133, 

0,lP4,2i5, 

224, 

316, 

29, 

30, 

134, 

177, 

183, 

215, 

224, 

3 1 5 , 29,  32,135, 

173,180,213, 

224, 

311/ 

DAT*  iw«/ 

* 33,135,  0, 170,21  1, 223, 30«,  0,  0,135,166,  0,210,222,306,  0, 
*16«,206,223,29<i,2<»7,  0,3q9,  C , 1 35 , 164 , 207 , 22a  , 0 , 29 1 , 300 , 30* , 
*135,164, 206,226,266,  0 , 30 0 , 3o8 , 1 35 , 1 62 , 2o4 , 22« , 285 , 302 , 305  , 0, 
*134,161,203,224,265,303,  0,  0 , 1 34 , 16 1 , 203 , 224 , 205 ,303 , 0,  0, 
*130,159,197,201,223,286,303,  0,  134, 156, 144,222,287, 303,  0,  0, 
*134, 155, 194, 221, *67, 303,  0,  0,1  33,193,221  , 0,  0,  0,  0,  0 , 
*132,153,194,219,  0,265,299,306,130,153,194,218,279,  0,298,306, 
*123, 128,152,195,216,276,296,305,120,152,197,213,275,293,305,  0, 
*120,152,197,212,275,  0,3o5,  0 , 1 25 , 198 , 209 , 27  3 , 29 1 , 306 , 0,  0, 
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* 1 17,126, 152,20 1,207,272,290, 306,1  17,126, 152,20  3, 207,272,290, 306, 

*129,  0, 150,206,269,  0,  0,  0,132,147,  0,  0,  0,251 ,290,306, 

* 0,138,143,  0,240,254,290,306,140,245,255,261,  0,267,200,305, 

* 0,242,254,260,200,305,  0,  0, 140, 242, 254, 260,26*, 305, 312,  o, 

*138, 143,234,240,257,291,300,  0,139,146,231,294,315,  0,  0,  0, 
*140, 147,230,294,315,  0,  0,  0,149,296,  0,  0,  0,  0,  0,  0, 

* 0,138,150,220,297,317,  0,  0,135,  0 , 150 , 220 , 297 , 3 17 , o,  0/ 

CATA  1*5/ 

*134, 150,227,299,310,  o,  0,  0,134,150,228,320,  0,  0,  0,  0, 

*134, 150,228,296,320,  0,  0,  0, 132, 152,220,294,320,  0,  0,  0, 

*131, 154,228,  0,321,  0,  0,  0,131,155,220,297,321,  0,  0,  0, 

*132,159,300,  0,  0,  0,  0,  0,134,161,  0,230,  0,303,314,  0, 

*1  34,163,188,230,296,30  3,314,  0, 133, 166, 106, 1 9 J ,227,293,300,314, 

*1  31,1  67,103,194,223,293,314,  0 , 1 3 1 , 1 67 , 102 , 1 95 , 22 1 , 293 , 3 1 4 , 0 , 
*128,170,176,190,210,215,219,296,125,136,  0, 180,206,212,  0,314, 
*124,134,138,  0,203,  0,299,314,132,300,314,  0,  0,  0,  0,  0, 

*123, 129, 139,300,314,  0,  0,  0,123,127,140,300,314,  o,  0,  0, 

*122,125,141,314,  o,  0,  0,  0,122,142,299,312,  0,  0,  0,  0, 

* 0,143,299,312,  0,  0,  0,  0,144,299,311,  0,  0,  0,  0,  0, 

*145,296,312,  0,  0,  0,  0,  0,146,296,312,  0,  0,  0,  0,  0, 

*146,299,311,  0,  0,  0,  0,  0,146,302,308,  0,  0,  0,  0,  0, 

* 146,  0,  0,  0,  0,  0,  0,  0,141,1  46,  0,  0,  0,  0,  0,  0, 

*130,144,317,320,  0,  0,  0,  0,137,  0,317,321,  0,  0,  0,  0, 

*135,317,323,  0,  0,  0,  0,  0,134,325,  0,  0,  0,  0,  0,  0/ 

CAJA  l>6/ 

*1  34,310,326,  o,  0,  0,  0,  0,1  34,320,  0,  0,  0,  0,  0,  0, 

*133,322,  o,  o,  0,  0,  0,  0,132,323,329,  0,  0,  0,  0,  0, 

* 0,  0,132,323,330,  0,  0,  0,  0,  0,131,324,  0,  0,  0,  0, 

* 0,  0,1  31,325,333  , 0,  0,  0,  0 , 1 3 1 , 32b , 336 , 0,  n,  ft,  o, 

*131,327,  0,  0,  0,  0,  0,  0,119,131,328,338,  0,  0,  0,  0, 

*116,120,132,329,  o,  0,  0,  0,114,119,134,  0,  0,339,  0,  0, 

*114,116,135,294,330,340,  0,  0,113,117,136,293,297,332,  0,  0, 

*1  1 1,1  17,1  37,293,299,  0,341  , 0 , 1 1 1 , 1 1 7 , 1 37 , 293 , 299 , 333 , 342  , 0, 

*113,119,137,293,299,334,342,  0, l 14, 120, 130,293,300,  0,343,  0, 

*114,120,130,293,300,335,  0,  0,116,120,138,299,344,  0,  0,  0, 

* 1 19,1  35,  0,  0,29  1,300,339,344  , ft , 1 35 , 1 44 , 1 5 0 , 29 1 , 300 , 340 , 344  , 

*1  22,1  32,141,147,153,290,299,  0 , 1 3 1 , 1 38 , 1 55 , 28 7 , 294 , 0 , 0 , ft, 

*131,137,155,287,294,342,345,  0,134,135,153,207,291,339,347,  0, 

*151 ,287,291 ,336,348,  0,  0,  0 , 1 5 0 , 207 , 29 1 , 3 35 , 348 , ft,  0,  0, 

*149,285,  o,  0,  0,  0,  0,  0,  149,282,289,  0,329,345,  0,  0 , 

*140,281,290,326,344,  0,  0,  0,146,279,291,320,323,342,  o,  0/ 

DATA  L*7/ 

*1“4,276,293,  0,  0,317,339,  0,143,275,  0,296,314,  0,335,  0, 

*142,273,299,302,305,308,311,336,141,271,333,  0,  0,  0,  0,  0, 

*140,270,332,  0,  0,  0,  0,  0,138,27ft,  0,  0,  0,  0,  0,  0, 

*136,269,336,  0,374,377,  0,  0,138,269,  0,342,374,377,  0,  0, 

*139,269,350,356,362,368,  0,  0,140,269,  0,  0,  0,  ft,  0,  0, 

*140,264,  0,  0,  0,  0,  0,  0,140,269,  0,  0,  0,  0,  0,  0, 

*141,267,  0,  0,  0,  0,  0,  0,141,265,  0,  0,  0,  0,  0,  0, 

*143,264,  0,  0,  0,  0,  0,  0,144,263,  0,  0,  0,  0,  0,  0, 

*144,263,  0,  0,  0,  0,  0,  0,146,264,  0,  0,  0,  0,  0,  0, 
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109,  0,266,  0, 

0,  0, 

0, 

0,  0,152,266,  0,  0, 

0, 

0, 

0, 

153,213,267,  0, 

0,  0, 

0, 

0,155,  0,212,216,219, 

0, 

267, 

0, 

156,165,212,  0, 

0,222, 

267, 

0,159,162,210,225,267, 

0, 

0, 

0, 

161, 170, 20R, 230, 

0,267, 

", 

0,  0,170,209,  0,233, 

267, 

0, 

0, 

171, 209, 236, 23R, 

267,  0, 

0, 

0,173,207,  0,205,267, 

0, 

0, 

0, 

173,207,202,  0, 

267,  0, 

0, 

0,171,206,208,267,  0, 

0, 

0, 

0, 

170,206,200,267, 

0,  0, 

0, 

0,169,206,209,267,  0, 

0, 

0, 

0/ 

cata  l*b/ 

165,206,251,267, 

0,  0, 

0, 

0,163,197,201,20",252, 

267, 

0, 

0, 

162,197,  0,  0, 

252,267, 

0, 

0,161,197,250,267,  0, 

0, 

0, 

0, 

161,197,255,267, 

0,  0, 

0, 

0,161,197,256,267,  0, 

o, 

0, 

0, 

160,195,258,267, 

0,  0, 

0, 

0,159,  0,  0,190,261, 

o, 

267, 

0, 

159,186,186,19a, 

0,263, 

267, 

0, 160, 180, 189, t94, 266, 

0, 

0, 

0, 

161,179,191,194, 

0,  0, 

0, 

0,162,178,191,190,  o, 

0, 

0, 

0, 

160,177,191,194, 

0,  0, 

0, 

0,166,176,192,195,  0, 

0, 

0, 

0, 

168,175,192,195, 

0,  0, 

0, 

0,170,173,192,195,  0, 

0, 

0, 

0, 

171,191,195,  0, 

0,  0, 

0, 

0,  0,191,195,  0,  0, 

0, 

0, 

0/ 

* DETERMINE  the  mAP  SCALE  and  the  GRID  POINTS  T9  be  printed. 

* NDGP  5 DISTANCE  PETkEEN  GRID  POINTS  IN  MAP  LN I TS , 

* NWST  = MAXIMUM  HICTh  (iF  A Map  STRIP  IN  MAP  UNITS. 

* NPRINT  s DISTANCE  BETWEEN  PRINTED  GRID  POINTS  IN  MAP  UNITS. 

MTalABS(MTYPE) 

IF(MT.EG.O)  return 

IF(MT.GT.OO)  GO  TO  98 
IE(MTYPE.LT.O)  NDPLs1°0 
IF (MT.LE.3C)  GO  TO  11 
MESMaMT-30 
N*STs 1 25*NDPC 
NDGP*720/MESH 
NPRINTsINCH 
GO  TO  13 

11  IF (MT.LT ,20)  GO  TO  12 
MESWsMT-20 

NWSTr 120*NDPC 
NDGPslOBP/MESM 
NPRlNTsINCMAH 
GO  TO  13 

12  MESMs-i 
NDGP*MT * INCH 

N"STx(U25*NDPC)/NnGP)*NDGP 

NPRINTsNDGP 

13  NDGPHsNQGP/2 
GDISTsNDGP/FLOAT(INCH) 

IPDlST«NPRINT/PLOAT(NrGP) 

FNDGPHsEL0AT(N0GPH1 

FNDGPsFLOAT(NpGP) 

FNDPCsFLOAT (NDPC) 

FNDPL*FL,i'AT (NQPL  1 
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HAPSCls(*T-MESH)*«ESH 

SCL20=a0./FLflAT(MAPSCL) 


* DEFINE  THE  HINCO*  TO  bE  HAPPED, 

* ICMN.ICHAX  s left  AND  RIGHT  SIDES  OF  WIND"*  IN  hap  units, 
« JCHIN,JCHAX  s 80TT0N  aNC  TO P EDGES  0?  MNDOW  jn  hap  UMTS, 
« JCNJ  = TOP  OF  THE  GRID  IN  HA*  UNITS, 


M =1 1 

IF(LJ.LT.O)  NIsLI-1 
\JsIA0S(LJ) 

IF(LJ.LT.O)  NJsNJ-l 
L = LL 

IF  (Iw  + L,GT ,NI)  LsM-Ih 

M -MV 

IF  ( J * + M , G T ,NJ) 

IF (NI .LT.a.OR.Nj.LT.R)  GO  TO  R6 
I F ( L.LT.3.0R,  h.lt,3)  GO  TO  9S 
IF(lM.LT.l,3R,J«.LT.n  GO  TO  gfi 
I C H I N 3 0 
ICHAX=NDGP*L 

ICHAXsICHAX-HOD(ICHAX,NOpC) 

ICIWsN0GP*(Ih-1 ) 

JCM I N=0 
JChaxsNCGPaH 

JChax=JCHax-MOCCJChax,ndPLT 

JCNJsnDGP*(NJ-JH) 

JOs'-OGP*  ( Jm-1) 

* CORRECtIPNS  for  STAR  gric  and  FOR  NON-STANDARD  P"LE. 
STC’RXsO. 

IF  (LJ.LT.O)  STCORXsFNDGPH/FNOPC 
STCCRYSO. 

IF(LJ.LT.O)  STCORYsFNCGPH/FNDPL 
f IP*51  ,/FlOAT  (LI-1 ) * r i_ 0 A T ( I *•  1 ) 
FJOi55,/FL0AT(LJ-n*FL0AT(jH-n 
PCORXsFIP*FNDGP/FNDPC 
PCORYsFJP*FNDGP/FNDPL 

* CALCILATE  INTERPOLATION  CONSTANTS. 

IF  (CINT.ta.O.)  GO  TO  R 8 
CSMFTeo.O 

IFfCINT.LT.O.)  CSHlFTsO.5 

CSCsabS(SCALE/CINTI 

CSC2«CSC/2. 

CSCfcsCSC/6. 

SIxThsI ,/b. 
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« HAP  STRIP  LOOP.  RETlRN  IF  LAST  STRIP  IS  FINISHED. 

* IPCL#IPCR  = LEFT  AND  RIGHT  SIDES  OF  MaP  STRIP  IN  MAP  UNITS. 

* IPNTL  * POSITION  OF  FIRST  PRINTED  GRID  POINT  JN  MAP  UNITS, 

1PCR»ICMIN 
15  IPCL=IPCR 

IF(IPCL.GE.ICHAX)  GO  TO  16 
IPCRslPCL+NWST 

IFflPCR.GT.ICHAX)  IPCR«ICHAX 
NCHHAX*(IPCR-IPCL)/NDPC 
FPCL=FLOAT(IPCLtICIM/FNDPC 
IPNTLsIPCL 

IPNTCsMODCIPCL.NPRINT) 

IF(IPNTC.NE.O)  IPNTL«TPNTL*NPRINT-IPNTC 

WRITE (6,610)  CINT,SCALE,GDIST,IPDIST,LI,LJ,IW,JW,LL,MM,MT 

* START  OF  PRINT  LINE  L"OP  FOR  EACH  MaP  STRIP. 

* J IDENTIFIES  THE  LO'-'ER  SIDE  OF  THE  INNER  INTERPOLATION  SQUARE . 

* Q s DISTANCE  OF  THE  CURRENT  ROW  FROM  ROW  J IN  GRID  UMTS, 

* JPL  * POSITION  OF  CURRENT  PRINT  LINE  IN  MAP  UNITS. 

JPL=JCMAX 
21  J*JPL/NOGP*JW 

IF  CJ.GT.NJ-2)  JsNj-2 
IF (J ,LT,2)  J =2 
JDIF=JPL-(J-JW)*NDGP 
QsFLOAT (JDIF)/FNDGP 
GAsCSC6*(-Q*(Q-l.)*(Q-2. ) ) 

GB*CSC2*(  (Q-l,)*(Q4].)*(Q-2.)) 

QCtCSC2*(-Q*(Q+l.)*(Q-2.) ) 

GDaCSC6*(  Q * (Q+  1 . ) * (Q-  1 . ) ) 

* START  of  print  CHARACTER  LOOF  for  Each  print  line. 

* i identifies  The  left  side  of  the  inner  interpolation  square. 

* p = DISTANCE  OF  THE  CURRENT  PRINT  CHARACTER  FROM  I IN  MAP  UNITS, 

ILASTs-1 

NCH=0 

CO  40  IPC=IPCL,IPCR,NrPC 
nch-nch*  l 

IMPC/NDGP  + IW 
IFCl.GT.NI-2)  IaNI-2 
IFCI.LT. 2)  1 = 2 

IDIFsIPc-(I-IW)*NDGP 
P=FLOAT(IDIF)/FNDGP 
IF  C I, EG, IL AST)  GO  TO  3« 

IFCILAST.GT.O  ) GO  TO  30 

ZP=CA*Z(I»l,J-l)+QB*Z(I-l,J)+QC*Z(I-l,J4l)4QD*Z(Ial,J+2) 

ZCaQ A*Z ( I ,J-1)4QB*Z(I  ,J)4QC*Z(I  ,J*1)+QD*Z(I  ,J*2) 

ZD=GA*Z  ( I ♦ 1 , J-l  )+QR*Z  (I  + l , J)4QCwZ  ( I ♦ 1 , J+1)+GD*Z  (U1 , J + 2) 
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38  Z A»ZB 
ZBsZC 
2 C s Z C 

ZDsGA*Z(I>2/J-l)*aB»Z  Cl *2,  J)OC«Z(I*2,  J + l )qQD*Z{I*2,  J + 2) 
ILASTsI 
3?  CPNTINUE 

PAiSXXTh*(«P*(P.1 ,)«(P-2()) 
pB  s 0 . 5*  C Cp-l.)*(PM.)*Cp-2.n 
PCs  0.5*(-P*(PM.)*(P-2.)) 
pd«sixth* ( p* (o*] , )* (P-i , ) ) 

CBMaPA»ZA*PB*ZB*c'C*ZC  + PD*ZC  ♦ CS^IFT 
NC9NTaIM(CBMT) 

KC8NT«MeC(NC0NT#8)*i 

IF  (CBST  ,LT  .0. ) NC'NTsT  + KCCM 

NPPUlNCKCH)sKABCr(NCBM) 

40  C8NTINLE 

« DRa*  lANC""ATER  BOUNDARIES. 

« Njpflo  IS  The  CURRENT  P8»  I»-AGE  in  The  1/20H  SCAlE  map, 

NJR8»s(FL0AT(JPI*JC>)/FNCpI  ♦ STC8RT  ♦ pC8RY)/SCl20  ♦ 0.5 

IP(NJRP*,LT,l,8R.NJP0*»,GT,2a2)  G*  T8  u9 

DC  44  Ksl.8 

U«lSL*E(k,NJp0.O 

IF(L»c.EC,0)  GO  T 8 44 

NCB  = pl8aT(|.*L)*SCL20-fpcL-STC?RA-PC8RX4O.5 
IPl^CB.GT.fl.ANC.'-CP.LE.NCHMAX)  NPSLIN(NCB)*N0CT 
44  C8NtINLE 


« INSERT  grid  P?r,T  Values  if  This  is  A grid  R8«  Tfl  be  PRINTED. 

* pupating  gP I D vauieS  aR^  SCAtEDi  ROUNDED  aNC  r.9»,VERTED  T 8 I n t^ge 

* SIGN  AND  U8WEST  pJuR  DIGITS  ARE  INSERTED  INTO  NPRUIN. 

u9  NC-PsNCh+I 

C 8 51  NN  = >.C><P  , 1 30 

51  nppuin (nn)sn  plank 

IF ( JPu/NPRlNTaNPKiKT.KE.JPU)  GO  T P 57 

* = J 

IF (JPL.EG.JCNJ  ) <SNJ 

IF  C J p L , EG  , JCNJ«NDGP  ) xssj-l 

IR(JpL.EC.O)  *«J» 

NPRLIN(1)sNSTAR 

NRRlIN(nC-)snSTas 

CP  35  IPNTriPNTL , :PCp,NpRlNT 

Is!FNT/‘,CGpAl- 

NC-s(IpNT-lPCL)/NDpC*fc 

P=Z(I,K)*SCALE 

I G s I *.  T (ABS(p)+0,5) 

NpRLlN(NC^-5)=NpLLS 

IFcp.lT.C.)  m>RLIN(NCm-5)SnminlS 

DP  Eli  NNS1  ,U 
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THIS  PAGE  IS  BEST  QUALITY  PRACXICABIfl 
JRUM  COPY  FURNISHED  TO  DDC  _ 
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IQ  1 Oa IQ/ 1 0 

NPRLIN<NCH-NN)«NUMBER(IQ-IGlO*10*n 
5«  I Q s I Q 1 0 
55  CONTINUE 

* PRINT  ONE  LINE.  IF  NOT  END  OF  STRIP  GO  BACK  To  PRINT  LINE  LOOP 

* AT  STATEMENT  21.  OTHERWISE  START  NEW  STRIP  *T  STATEMENT  15. 

57  WRITE (6 • 620 ) NPRLIN 
JPL»JPL-NDPL 

IF(JPL.GE.JCMIN)  GO  TO  21 
GO  TO  15 

lb  CO  17  IX«1,LI 
17  X(IX)=FLOAT(IX) 

DO  16  IY»1#LJ 
16  V(IT)sFLOATflY) 

CALL  C0NT0R(Z,X,Y,LI,LJ,0,10,IW,LL,JW,MM, * $ ' , FLOAT (MTYPE ) , 

*0.#0.#0.) 

RETURN 

98  WRITE (6,698)  C I NT , SC  ALE , L I , L J , I w , jw , LL , MM , MT YPE 
RETURN 

610  FORMAT ( 1H1,5X,8HC0NT0LR*, 1PE1 1.4#5X,6HSCALEb,E1  1 .4,5X,5HGPICb, 

W0PF7,«,21M  Inches  print  EVERY, 13, 5X,6I<J,I6//) 

620  FORMATdH  ,130A1) 

696  FORMAT  (22H  ILLEGAL  CALL  TO  PCONW,  lP2El<l. 4,916) 

END 
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SUBROUTINE  FFGFH2(GR,LGR,FW,LFK, IR# IL0NG#WRKS,NL) 

* CONVERTS  IR  COMPLEX  FOURIER  COEFFICIENTS  IN  Fw(LFW,NL) 

* to  ILONG  EQUALLY  SPACED  GRID  POINT  VALUES  IN  GR(LGR>NL) 

« 6v  THE  FAST  FOURIER  SUBROUTINE  F0R12S. 

complex  FWCLFWfNL)#NRKS(n 
DIMENSION  GR(LGR.NL) 
complex  AA,BB,CC 
DIMENSION  N Y ( 3 ) 

IRPUIR41 

lF(MOD(ILONG,3).EfI.O)  GO  TO  100 

* CASE  1 - ILONG  IS  A POWER  OF  2. 

* MAX  IR  IS  ILONG/2.  WRKSs(ILONGM)  COMPLEX  WORDS. 

IF CIR.GT.ILONG/2)  wRITE(6,6010)  IR, ILONG 

IF (Ir.GT. ILONG/2)  RETURN 

ILG2=IL0NG«2 

NxMAXslLONG/2  ♦ 1 

wPKS(NWMAXM)  = (0.,0.) 

CO  50  t=l,NL 

* COPY  WAVES  0 TO  IR  TO  WRKS.  FILL  TO  WaVE  ILONG/2  WITH  ZERCS. 

DO  20  JsIRP1,Nw“aX 
20  >-.RkSCJ)  = (0.,0.) 

CO  30  Jal.IRPl 
30  wRKS(J)sFW(J,L) 

* perform  the  fast  folrier  transform, 

NsILONG 
ISIGNsl 
NTYPs- 1 

call  F0UR2(WRKS,N#1,ISIGN,NTYP) 

* COPY  ILONG  GRID  POINTS  FROM  WRKS  TO  GR. 

NX  = C 

CO  40  Isl.ILONG,? 

NXsNX+1 

GR ( I ,L)a  REAL (WRKS  (NX) ) 

GP(I+l,L)aAIMAG(WRKS(NX)) 

40  CONTINUE 
50  CONTINUE 
RETURN 

* CASE  2 - ILONG  IS  3 TIMES  A POWER  OF  2. 


J 
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* MAX  VALUE  OF  I*  IS  ILONG/3.  WRKSs ( II 0NG/6+ 1) *8  COMPLEX  WORDS. 
100  KJ  s ILONG/3 

IFCIR.GT.K3)  WPITEC6#6010)  IR,IL9NG 

IFCIR.GT.K3)  RETURN 

K6  s K 3/2 

KP6  : K6  t 1 

NWMAX  • 2*KP6 

NRKS (7*KP6*1 ) s C0.f0.) 

CALL  PERM(WRKS(2*KPe^l ),WR«S(3*KP6tl ), AA/BB/KP6,K3) 

CO  150  L=1,NL 
CO  120  j=irpi,nrmax 

120  wPKS(J)  e (0.,0.) 

no  130  J«1,IRP1 
130  S ( J ) s FW(J,U 

CO  160  K*1,KP6 

CC  s C0NJGCWRKSCK3+2-K)) 

*RKS (R*KP6tK)  s NRKS(K)  ♦ CC 

*RKS  (5*KP6tK)  s fWRKS(K)+,*B*CC)*WRKS(2*KP6  + K) 

160  *PKS (6*KP6  + K)  s (WRKS(K)  + AA*CC ) *WRKS C3*KP6+K  ) 

N s K 3 

ISIGN  = 1 
NTYP  = -1 
NYC1)=K3 
NY(2)=K3 
NY(3)SK3 

CALL  F0UR2(WRKS(«*kP6+1 ),NY,3,ISIGN,mtyP) 
fcFKS(7*KP6)  s wRKS C6*KP6+1 ) 

CO  170  K = 1 * K 6 
KP  s (K-l)*6 

GR(KP  + J#L)=  REAL  (WRKS(U*KP6  + K)  ) 

GP(KP  + 2,L)  *REAL  (RRKS (5*KPfafK ) ) 

GRC*P+3,L)8  AIMAGCWRKS(6*KP6tK)) 

GR(KP  + <i,L)s  AImag  (nRKS  (U*KP6  + K) ) 

GR (KP+5, L ) * AIPAG (WRKS (5*KP&  + K)  ) 

170  GR(KP+6,L)s  REAL(WRKS(6*KP6tK+l)) 

150  CONTINUE 
RETURN 

6010  FORMAT (3RH  ILLEGAL  CALL  TO  FFGF W2 . , I R , I L ONG« , 2 1 S ) 

end 
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SUBROUTINE  FFWFG2(Fw,LFW,GR,LgR, IR# ILflNG#WRKS,NL} 


* CONVERTS  ILONG  EQUALLY  SPACED  GRID  POINT  VALUES  IN  EACH  LEVEL  OF 

* GR(LGR,NL)  TO  COMPLEX  FOURIER  COEFFICIENTS  IN  FW(LFW,NL) 

* TO  WAVE  NUMBER  IR,  USING  THE  FAST  FOURIER  ROUTINE  F0R12S. 

complex  FW(LFW,NL) 

DIMENSION  GR(LGR»NL)*WRKS(1) 

complex  aa,bb 

DIMENSION  N Y ( 3 ) 

I«P1=IR+1 

IF(POD(ILONG,3).FQ.O)  go  TO  100 

* CASE  1 - ILONG  IS  A POWER  OF  2. 

IF (IR.GT.ILONG/2)  wRTTE(6,6010)  IR, ILONG 

IF (Ifi.GT.ILONG/2)  RETURN 

ILG2=IL0NG+2 

FLINVsl ,/FLOAT (ILONG) 

wRKS ( ILG2+ 1 ) »0 . 

CO  50  L=1#NL 

* TRANSFER  GR  TO  WRKS  AND  DIVIDE  BY  ( 2*  I L ONG ) , 

DO  20  1=1, ILONG 
20  wRkS(I)bGR(I,l)wFlINV 

* PERFORM  THF  FAST  FOURIER  TRANSFORM, 

NsILONG 

ISIGNs-1 

NTYPsO 

CALL  F0UP2(WPKS,N,1,ISIGN,NTYP) 

* TRANSFER  COMPLEX  WAVES  0 TO  IR  FROM  WRKS  TO  FW. 

NXa-  1 

DO  ao  J = 1 , IRP 1 
N X sN  X ♦ 2 

ao  fw(j,l)=CmplX(wrks(NX  ),wRkS(NX*i  )) 

50  CONTINUE 
RETURN 

* CASE  2 - ILONG  IS  3 T^eS  A POWER  OF  2. 

* max  value  of  IR  IS  ILONG/3.  WRkS=(IL0NG/6+1)*8  CqmPlEX  WORDS. 

100  FLINV  = ,5/FLOAT ( ILONG  ) 

K3  * ILONG/3 

IFCIR.GT.K3)  WR ITE (6 » 60 1 0 ) IR, ILONG 
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IFCIR.GT.K3)  RETURN 
Kt>  s K3/2 
KP6  a K6  ♦ 1 
NRKS(1<1*KP6+1)  s 0. 

CALL  PERH(WRKS(«*KP6+1) ,WRKS(6*KP6*1 )# AA,B0,KP6#K3) 

On  150  L=1,NL 

DO  130  Ks l # K 3 
KP  3 (K-l)*3 

wPKSC8*KP6  + K)  3 GPCKP+1,U*PLI^V 
wRkS ( 1 0 *KP6aK ) s GR(KP+2»L)*FLINV 
130  KRKS(12*KP6  + K+1)  s G«  ( KP  + 3 , L ) *F LI N V 
WRKS(l2*KP6M)  b WRKSC12*KP6  + K3  + 1) 

N3K  3 

I5IGN  s -1 
NT  YP  s 0 
NYCl)sK3 
NYC2)sK3 

N Y ( 3 ) sK  3 

CALL  F0UR2(WRKS(8*KP6+1)#NY,3,ISIGN#NTYP) 

CALL  PC0MCwRKSC4*KPfc+l),wRKS(b*KP6+l)#AA»B6,WRKSCB*KPb+t), 
1 NRKS(lO*KP6*l),WRKS(l2*KP6+l) , WRKS C 1 ) # KP6 , K3 ) 

NX  s -1 

DO  lfco  J = 1 # IRP 1 
NX  s NX  + 2 

160  FW(J,L)  = CMPLX (WRKS (NX) , WRKS  (NX  + 1 ) ) 

150  continue 
return 

6010  FORMAT (3PH  ILLEGAL  CALL  TO  FF WFG2 . , I R , IL "NGs , 2 1 0 ) 

end 

FAST  FOURIER  TRANSFORM  TO  REPLACE  "FOUR 2*  AND  "FOUR^S"  IN 
ThE  GLO0EX  MODEL.  SHOULD  BE  TF ANSPaRENT  TO  THE  USER. 


• ill 
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SUb^HTINt  F0UR2(F,N,T,  is,  IT) 


CPMM0N/FFTDAT/T1  (400), T2  (400) 
real  D(2»200),E(1),F(2,1) 

EQUIVALENCE  (Dtl,l),Etn) 

DATA  IC,IH/O,0/ 

CHECK  INPUT  data  - VERY  CURSORY 

I F ( (N/2 ) *2 , NE , N ) ST OP  OR 
If  (IT.LT.-1  .(TR.IT.GT.O)  STOP  7n 

IF(lH.NE.lS.nR.lC.EG.C)  CALL  FOURIN(IS, N) 

IH=IS 
ICs  1 

ISo=IT+2 
IN23N/2 
IN2Hl=IN2-l 
IN2P1  = IN2M 
GO  T o (1,2), IS* 

rPOOSE  T*E  type-  of  TRANSFORM 

1 =>  1/2  complex  array  TO  A RFaL  ARRAY 

2 =>  A REAL  ARRAY  TO  1/2  COMPLEX  ARRAY 

1 DO  3 I = 1 , IN2P  1 
D(l, I) =F  (1,1) 

3 C (2, 1 )=F (2, 1 ) 

CO  11  1 = 1,1 U2H 1 
D(l,N-I+l)=F(l,I+l) 

1 1 C (2rN.Nl)s.F  (2,1  + 1) 

GO  TO  a 

2 DP  5 1*1,  IN2 

CO  5 J=  1 , 2 

5 0(J,I)=F (J,I) 

CO  6 1*1, N 
I r'sN  - 1 ♦ i 
C(1,M)  = ECIH) 
fc  0(2,IM)=0.0 

4 CALL  F0URTR(D,D,T2,N, IFIX(ALOG(FL0AT(N) )/AL0G(2.)+0.5)) 
GO  TO  (7*10), IS N 

PRFPARE  THE  OUTPUT  ARRAY 

7 DO  g 1=1, N 

8 E(I)=n(i,n 
CO  12  1=1, IN2 
DO  1?  J = 1 , 2 

12  F(J,I)=D(J,I) 

RETURN 


10  DO  <5  I31,1N2P1 
DO  9 J=1 ,2 
9 F(J#I)sO(J,I) 
RETIRN 

end 


95 


I 


FUNCTION  GAMS AT ( T , C S ) 


* COMPUTES  *GAWS AT  * WHICH  WHEN  MULTIPLIED  BY  CaPA/SIGMA 

* GIVES  THE  moist  ACIABATIC  lapse  Rate  of  potential  TEMPERATURE 

CPmmon/GAMS/EPSS.CAFA 

HTsHTVOCP(T) 

AsHT*QS/(CAPA*T) 

AbsA*EPSS*HT/T 

GAHSAT*T*(AB-A)/a.  + AB) 


RETURN 

END 
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SUBROUTINE  GARPIN(nF1,NFMTN,NF2,NDAY,LV,PR,ILG,ILAT, 

1 mTN,HET,kdR,KRT,kCV,  IW,JW,LL,MM, 

2 MPGZ,MPT,MrW,MPHSP,MPGZS,MPSP,MPCR,MPWT,MPCV) 

* THIS  PROGRAM  GETS  SPECTRAL  DATA  FOR  ONE  0 AY  (NDAY)  FROM  THE 

* GARP  TAPE  (NED  and  CONVERTS  TO  GAUSSIAN  GRIDS  FOR  8UTPUT(NF2). 

* ALL  SPECTRAL  fields  ON  The  tape  are  DIMENSIONED  (27,26), 

* PUT  THEY  ARE  TRUNCATED  at  wave  NUMBER  25  so  the  last  complex 

* NUMBER  in  each  row  is  UNUSED.  SUBROUTINE  SMOV2  is  USED  TO 

* CONVERT  THESE  FIELDS  to  THE  STANDARD  (26,26)  SIZE. 

* NOTE  - HINDS  U,V  HAVE  SIZE  (27,2b)  IN  The  PROGRAM, 

* geopotentuls  c g 2 ) are  computed  f p oh  temperatures  (TGG) 

* AND  SURFACE  PRESSURE  (PSGG).  GZ  AND  TgG  ARE  STORED  ON  NF2. 

* *ind  components  cl,v)  are  computed  from  vorticity  (o)  and 

* DIVERGENCE  (07  AND  SAVED  ON  NF  2 ) , 

* NOTE  - ACTUAL  MINUS  COMPUTED  ARE  (U,V)*COS(LAT)/(EARTH  PACILS) 

« THE  DAYS  ON  THE  TAPE  ARE  NOV  4,  5, 6, 7, 0,9  ( t <5  6 q 5 . 

* T,G,D  ARE  AVAILABLE  ON  10  PRESSURE  LEVELS. 

* THE  ORDER  OF  THE  PRESSURE  LEVEL  DATA  ON  THE  TAPE  IS 

* 50,150,250, 350,450, 550,650, 750,050, 950  Mp. 

parameter  SILVsi5,JLEV5o,SLV=io,SILTs52,SILGs6«,SlLTHs26,*IR=20 
logical  mtn 

LOGICAL  wET,KOR,KWT,KCV 
DIMENSION  PR(LV) 

DIMENSION  MPT(i ),mpgZ(1 ),MPH(i),MPWSP(l) 

COMPLEX  Q,D,U,V 

COMf>0N/LCMl/  G(26,2ft),D(2b,26),U(27,26),V(?7,26) 

COMMON/LCM2/  GG(330O)  ,GGp  (2')O0)  ,wRKL  C130) 

COMM0N/LCM3/PSGG (33gO) ,GZS (33p0) ,TGG (33eO, 1 1 ) , DyMMY (33  BO) 
dimension  Gzmeo,  1 1 ) 

EGUIVALENCE(GZ(1,1),TGG(1,2)) 

C0MHON/ALPC0M/  alp (2 R, 26), EPS  I (28,26) 

CoMMflN/GAuSS/HMILTH),H(-Cs('ILTH),CoA(JILTH),slA(sILTH),RAD(SlLTM) 

«,ANG(SILTH) 

CImensION  HRKS(3on,2),PRL(lo) 

* OUTPUT  PACKING  DENSITIES.  NO  PACKING  IF  SET  To  1. 

DATA  NPGZS,NPGZ,NPT,NPw,NPFS,NP*T,NPCV,NPCR 

1 / 1,  1,1,1,  1,  1,  1,  1/ 

* INITIAL  FIELDS  ARE  GLOBAL  AND  CONTAIN  Tfl  WaVE  25. 

* ILALP  s R0“.  LENGTH  of  ALP,EPSI  (MUST  PE  EVEN  AND  GT  IIRP2). 
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HAiPs2e 

IKHEMsO 

IKSYMsO 

IIR=25 

IIRPl«IIR+l 

IIRP2=IIRf2 

* SET  CONSTANTS. 

A s 6.37122E6 
GRAV=9, 8Q616 
RGAS*287. 

RG0CPa2,/7. 

ILATHsILAT/2 
1LG 1 = ILG+  1 
LGG=ILG1*ILAT 

CALL  EPSIL2CEPSI,ILALP,IIRP1) 

CALL  GAU3SG(ILATH,COA,W,SIA,RAD,W(5CS) 

* PPL  CONTAINS  THE  LOG  OP  SUCCESSIVE  PRESSURE  PATIOS 

* FOR  LATER  USE  IN  The  HYDROSTATIC  EQUATION  INTEGRAL. 

do  15  Lai»R 

15  PRLCL)*ALOG{PRCl*n/PR(l)) 

PRL(lO)sAl8GU00O./PR(lO)) 

id=o 

REWIND  nfi 

* IP  HTNSs.F.  JUST  SFT  MOUNTAIN  FIELD  TO  ZERO.  OTHERWISE  READ 

* SPECTRAL  MOUNTAINS  FROM  NFW TN  ONE  ROW  AT  A TIME  AND  CONVERT 

* TO  GAUSSIAN  GRID.  CONVERT  FROM  METERS  TO  GZ  AND  SAVE  ON  NF2, 

* NOTE  - MOUNTAINS  HAVE  SIZE  C2b,26D  ON  The  FILE. 

* NOTE  - MOUNTAINS  are  not  ON  THE  GARP  TApE.  USER  MUST  SUPPLY. 

DO  ao  1=1 ,LGG 

20  GZS(I)so, 

IF (.NOT.MTN)  GO  TO  23 
DO  21  M*1 1 1 IRP  1 

RE  AC (5*5020)  (G(N,M)(NsifIlRPl) 

21  CONTINUE 

CALL  SP AGG2 (GZS  , ILG 1 , ILATH.COA , IKHEM, 

1 Q.IIRPl, IIRPt, IKSYM,aLP,EPSI,ILALP,WRKS,WRKL) 

DO  22  1=1 ,LGG 

22  GZS(I)sGZS(I)*GRAV 

CALL  FC0NW2(GZS,-500., t./GRAV,ILGl,ILAT,lW,JwfLL,MM,MPGZS) 

23  CALL  WSGGP(GZS,ILG1,ILAT,NF2,ID,4H  GZS, 1 ,NPGZS,GGP,WRKS) 

* READ  SPECTRAL  TEMPERATURES  CDEG  c).  CONVERT  TO  GAUSSIAN  GRIDS. 


4R 


I 


Cft  2a  ND=4,R 
00  2a  L«l,  10 
REAC(NFl,5101)  U 

IF (N0.EQ.NDAY)  WRITE (6,6030)  L,ND 
IF(KO.EQ.NOAY)  CALL  S“ 0 V? ( Q , 1 1 RP 1 , U , 1 1 RP2 , 1 1 RP  I ) 
IF(NO.EQ.NDAY)  CALL  SP  ACIG2  ( TGG  (1 , L ) , I LG  1 , 1 L A TM C 0 A , I KHE  M , 

1 3,IIRP1,IIRP1,IKSYM,ALP,EPSI,ILALP,WRKS,WPKL) 

2 a CONTINUE 

* CONVERT  TEMPpPATURES  TO  DEG  K AND  SAVE  ON  NF2. 

00  32  L = 1 , 10 
CO  31  1=1, LGG 

31  TGG(I,L)sTGG(I,L)  ♦ 273.16 

CALL  FC0N*'2(TGGC1,U,  5.,l.,ILGl,rLAT,lw,Jw,LL,MM,MPT(L)) 

CALL  -SGGP{TGG(l,L),lLGt,ILATfNF2,I0,aH  T , L , NPT , GGP , wRKS  ) 

32  CONTINUE 

* GET  SPECTRAL  mSL  PRESSURF  C MP ) . CONVERT  TO  GAUSSIAN  GRID. 

C*  36  N0=a,R 

RE  AC (NF 1,51 01)  U 

IF (NO.EQ.NOAY)  «R  I TE ( 6 , 60 4" ) SC 

IF (ND, EG, N D*Y)  CALL  Sm P V2 ( G , 1 1 PP 1 , U , 1 1 PP2 , 1 1 RP 1 ) 

IF (NO.FG.NDAY)  CALL  SPAGG2C  PSGG  , I LG  1 , IL A TH , C 0 A , IKHE* , 

1 Q, IIRP1, IIRP1 , IKSY", ALP,EPSI, ILALP.URKS, WRKL) 

36  CONTINUE 

* COMPUTE  T 1 000  FROM  T<}50  ASSUMING  Q.6*(DRY  LAPSE  PATE), 

CPN=(1000,/950.)**(RGAS/GRAV*5,9E-3) 

00  42  IsliLGG 

42  TGG(I,ll)=TGG(I,10)»CflN 

CALL  FC0NW2(TGG<1,11),5.,1.,ILG1,ILAT,IN,JW,lL,MM,mpT(H)) 
CALL  FC0Nw2(PSGG,5., 1 ILG1 , ILAT, I", Jw,lL,mm,mPSP) 

* COMPUTE  GZ 1 000  FROM  P(MSL)ANC  T 1 000,  ASSUMING  T (MSL  ) =T  1 000  . 
CO  44  1=1, LGG 

44  GZ(I,ll)sQGAS*TGG(I,ll)*AL0G(PSGG(I)/1000.) 

* COMPUTF  THE  GEOP0TENTI ALS  PY  INTEGRATING  The  HYDROSTATIC 

* EQUATION  UP  FROM  The  1000  MB  LEVEL. 

C 3 4«s  K K = 1 , 1 0 
L=1  l-KK 
OT  46  1=1, LGG 

GZ(IfL)sGZ(I,L4l)  ♦ RGAS*.54(TGG(I,L)fTGG(I,l>l))*PRL(L) 

06  CONTINUE 
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* SAVE  GEOP«TCNTialS  ON  FILE  NF 2 


SCAL«1 ./(10,»GPAV) 

DO  (18  L=l,  10 

CALI  FC0NW2(GZC1,L)i  b.O,SCAl.,ILGl,ILAT,IW,JW,LL»«M,PPGZ(L)) 

CALL  WSGGPC  GZ(I,L)#ILG1,ILAT,KF2,ID»«H  GZ,L»NPGZ,GGP,WRKS) 

(16  CONTINUE 

CALL  FCeNW2CGZci,ll),6.0,SCAL(ILGl,ILAT,IW,Jw,LL»M*,MPGZnin 

* READ  SPECTRAL  VOPTICITV  (Q)  AND  DIVERGENCE  (D)  FROM  TaPE. 

* convert  to  wind  components  on  gaussian  grids.  save  on  file  nf2. 

* WIND  SPEED  IS  COMPUTED  FOR  DIAGNOSTIC  PURPOSES  ONLY. 

CO  50  Nr=d,NDAY 
00  50  L=l»10 

RE  AC (NF I » 5 1 0 I ) U 
RE  AC (NF l # 5 1 0 I ) V 
IF (ND.LT.NDAY)  G"  TO  50 
t*RITE(6,6050)  L,ND 

* COMPUTE  wind  COMPONENTS  FROM  VORTICITY  AND  ClVERGEFCE. 

CALL  SM0V2(n#IIRPl,l,IIRP2,IIRPl) 

CALL  SM0V2(D/IIRPI,V,IIRP2,IIRP1) 

CALL  0DAW2(U, V,G,D,EPSI,WRKS(1, l),WRKS(l,2), 

1 IIRP2,IIRP2,IIPPl»IIRPl#ILALP,IIRPl,IKHEM,IIfi) 

* CONVERT  U TO  GAUSSIAN  GRID  AND  SAVE  ON  FILE  NR2, 

CALL  SPAGG2(GG, ILGI » lLATH.COA, IKHEM# 

1 U,  IIRP2,nRPl,tIKSYM,ALP,EPSI/ILALP,WRKS,wRKL) 

CALL  FC0NW2  (GG,  10.,  A,  ILG1,IL  A T,I«,JW,LL,  MM,  MPN(U) 

CALL  WSGGP(GG,ILGI,ILaT,NF2,I0,«h  U,  L , NPw , GGP , «RKS ) 

no  uRi  isi,lgg 
uri  psgg(I)3GG(D 

* CONVERT  V TO  GAUSSIAN  GRID  AND  SAVE  ON  FILE  Nf2. 
call  SPAGG2(GG,ILG1,ILATH,C0A,IKHEM, 

l V,IIRP2,IIRPU-IKSYM,ALP,EPSI,ILALP,WRKS,WRKL) 

C*LL  FCCNW2(GG,10.,A,ILGl,ILAT,Iw,JH,LL,MM,MPW(|.)) 
call  WSGGP(GG,ILG1,ILAT,NF2,ID,(H  V,L,NPW,GGP,WRK$) 

* COMPUTE  WIND  SPEED  AND  MAP  IF  REQUESTED. 

DO  «<J2  I*J,LGG 

«92  PSGG(I)=SGRT(GG(I)**2  ♦ PSGG(I)**2) 

CALL  FC3NW2(PSGG,10.,a,ILG1 ,ILAT,IW,JW,LL,mm,mpwsp(L)j 
IF  (L.EQ.10)  GO  TO  52 
50  CONTINUE 
52  REWIND  NF 1 


I 
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< 


* THE  GRID  PHYSICS  FIELDS  ARE  SET  TO  ARBITRARY  PUT  REALISTIC 

* VALUES  FOR  THE  PURPOSE  OF  TFSTING  THE  SPECTRAL  MODEL . 

* SURFACE  ORAG  IS  SIHPLY  A FUNCTION  OF  THE  CRESS^N  DRAG 

* COEFFICIENT  and  tHE  MOUNTAIN  HEIGHTS, 

IF  C.NOT.KDR)  GO  TO  55 
CRCSSDsi,2E-3 
cc  5«4  1 = 1, LGG 

5«  GG ( I ) =CRE  SSD* (1,0  ♦ GZ S C I ) / 1 . E ) 

CALL  FC0NH2(GG,2O0., t.E5,ILGl, IL A T , I w , JR , LL , MM , -'RpR ) 

CALL  HSGGP (GG, ILG 1 , ILAT,NF2, ID,4H  DR, 1,NP0P,GGP,WRKS) 

* «ATER  TEMPERATURE  IS  A FUNCTION  OF  LATITUDE. 

55  IFC.NOT.KWT)  GO  TO  57 
DO  56  J=1 , 1 L AT 

IF (J.LE.ILATH)  wTEMP=273.+.5*FL0ATCJ) 

IF  CJ.GT.IL ATM)  wtemP  = 273.  + .5*FL0at  CILaT+1-J) 

DC  56  K=1,ILG1 
I=CJ-1)*ILG1  ♦ K 
GGCI)=wTEMP 

56  CONTINUE 

CALL  FC0NW2CGG,  3.,1.00,ILG1,IHT,Iw,JW,LL,MM,mPwT) 

CALL  HSGGP(GG, ILG1 , ILAT.NF2, lo,ah  W T , t , NP*T, GGP , WRKS ) 

* SEA  COVER  IS  DtTfFMjNED  FROM  The  MOUNTAINS  ANp  an  ASSUME  PCLAP 

* S'. OH  COVER  OF  6 LATITUDF.  CIRCLFS. 

57  IF(.NOT.KCV)  GO  TO  99 
DO  5*  J=1 , IL AT 
SNQKsO  , 

IF  CJ.LE.6.0R..J.GE.  CILAT.5))  SNOHsl, 

DO  56  Ks 1 , ILG  1 
I=CJ-1)*ILG1  + K 
GG ( I ) s 1 , 

IF (GZS (I) .GT.999.  ,CR.  SNOW.GT.O.)  GG(I)=0. 

56  CONTINUE 

CALL  FC0NH2(GG,-M.,  10.0,ILG1  ,ILAT,IW,JH,LL,HH,mPcV) 

CALL  *SGGP(GG,ILGl,ILAT,NF2,ID,4H  CV, 1 ,NPCV,GGP,WRKS) 

69  RtTLRN 


5020  FORMATC  10F8.3) 

5101  F6RMATC6E12.5) 

6030  FOPMaTCIIH  TEMP  LEVr L , 1 3 ,5H  ti«V,I2,15H  READ  FRoh  TAPE) 

6 04  0 FCR',AT(22H  SURFACE  PRESSURF  N0V,I2,15H  READ  FROM  TAPE) 

6050  FORM  a T ( 1 5H  VORT.DIV  LEVEL, 13, 5M  NOV, 12, 15*  REAp  FROM  TAPE) 

ENO 
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PROGRAM  GARP6 


* CONTROL  PROGRAM  FOP  GARPIN, 

* reads  io  level  data  from  the  garp  tape  for  date  nday 

* FOR  INPUT  TO  the  MULTILEVEL  SPECTRAL  MODEL. 

the  parameter  statement  is  used  to  define  the  maximum  number  of 
levels  or  POINTS  ALLOWED  for  EACH  type  of  matrix 

1 1 L V 5 number  of  SIGmA  LEVELS  (NOT  COUNTING  0,1) 

$lev  = MOISTURE  LEVELS 

SLV  s PRESSURE  LEVELS 

JILT  S LATTITUDE  POINTS  IN  GRIC 

JILG  MAXIMIM  NUMPER  of  GRID  POINTS  IN  LONGITUDE  CIRCLE 
JILTH  s $ ILT/2 

SIR  = maximum  NUMBER  of  WAVES  PERMITTED 
IlLPl  s SILG  ♦ 1 

JLAW  s (SILG  + 1)*IILT  OR  (SIR  ♦ 2)*(SIR  ♦ 1)*J1LV 

PARAMETER  $Il.Vsl5,$LEVs0*JLVsin,JILTe52,$ILGs6<l,$IlTHs26,$Ifise0 

LOGICAL  MTN,WET,KDR,KwT,KCV,KDIV 
DIMENSION  PR($LV),SIG( JILV),TOATIM(ia) 

DIMENSION  MPGZdl  ),MPT(U),MPW(10),MPWSP(10) 


DATA  LV, PR/10,  50  . , 150. ,250. ,350., <150. ,550. ,650. ,750. ,050. ,<55C.  / 
DATA  IDATIM/6*0, 7*  ' X',0/ 


* M a P CONTROLS  (0  MEANS  NO  MAP). 


DATA  lw(JW,LL,MM/  1,1,32,52/ 
data  MPGZ/  0,  0,  0,  0,  0,  0,  0,  0,  o, 

OATA  MPT  / 0,  0,  0,  0,  0,  n,  0,  0,  0, 

DATA  MPW  / o,  0,  j,  0,  0,  0,  0,  0,  0, 

DATA  «P*SP/0,  0,  0,  0,  0,  o,  0,  0,  0, 

DATA  MPG2S,HPSP,MP0P,MPWT,MPCV/  0,  0, 


0,  0 / 
o,  0 / 

0 / 

0 / 

0,  0,  0 / 


* INPUT  Tape  ( n F 1 ) , MOUNTAIN  FILE  (NFMTN),  OUTPUT  FILE  (NF2), 
CATA  NFt, NFMTN, NF2/  01,S3,«2  / 

* SPECIFY  THE  DATE  NDAY  (NOV  4 TO  q) . 


CAUL  INOUMP 

PEAC (5,5010)  NDAY 

MPT(5)=22 

mPwSP (5 ) »22 

MPSP=22 

MPD«s22 
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* READ  MODEL  PARAMFTEPS  FROM  CARDS 


RE  AC  CS, 50 10 ) 
READ  (5, 5010) 
READ (5*5012) 
RL  AC (5,5015) 
RE  AC (5, 5010) 


ILG,ILAT,KMEMf  IR, LEVS, DEE T 

IW, jw,ll,mm 

NK , (SIG(N),f|al,NK) 

mtn,wet,kdr,kwt,kcv,kdiv,scorl,scdpw 

KSTART,KT0TAL,IPRG,1PCP 


* WRITE  CONTROL  LABEL  OK  FILE  NF2 , 


CALL  SPLAB(NF2,2,LV,PP,NK,SIG,LLVS,ILG,ILAT,KMEM,IR,DEET, 

1 MTN,rtET,KDR,KWT,KcV#KDIV,KSTART,KTOTAL,IPRG,lPCP,IDATlM) 

* READ  THE  GAPP  Tape  and  °UT  OUTPUT  ON  FILE  NF  2 , 

CALL  GARPINJNFl ,NFMTN,NF2,NDAY,LV,PR,ILG,ILAT, 

1 mtn,wet,kdr,kwt,kcv,  IW,Jh,LL,MM, 

2 MPGZ,MPT,MPW,HPWSP,MPGZS,MPSP,MPCR,MPWT,MPCV) 


5010  FORMAT (SIR, F8.0) 
5012  F0RMAT(I5,15F5.3) 
5015  FORMAT (6L4,2Ffl,2) 
STOP 
END 


I 
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SUBROUTINE  GAUSSG(NZERO,F,WT,SIA,RAD,W0c5) 

* THIS  ROUTINE  CALCULATES  THE  ROOTS  (F)  OF  THE  ORDINARY  LEGENCPE 

* POLYNOMIALS  OF  ORDER  NZERO.  The  FIRST  STEP  IS  TO  HAKE  AN 

* INITIAL  GUESS  FOP  EACH  ROOT  AND  THEN  TO  USE  THE  ORDINARY 

* LEGENDRE  ALGORITHM  (ORDLEG)  AND  NEWTONS  METHOD  TO  REFINE 

* THE  SOLUTION  UNTIL  THE  CRITERION  XLI*  IS  SATISFIED. 

* F = COSINE  OF  COLATITUDE 

* WT  a CORRESPONDING  GAUSSIAN  WEIGHT 

* S I A S SINE  OF  COLATITUDE 

* FAD  = COLATITUDE  IN  RADIANS 

* wOCS  a GAUSSIAN  WEIGHT  / C OS ( C OL A T ) **Z 

DIMENSION  F(!),WTCl),$lA(n,RAD(n#HOcSCl) 

XLIHal  .OE-06 
PI  = 3.t«lSR2b535BRe 
IR  = 2*NZER0 
FlaFLOAT(IR) 

FIlsFI+i. 

FNaFLOAT (NZERO) 

DO  20  1=1, NZERO 
DOTaFLOATCI-i ) 

F(I)s.PI«,5*CD0T*.5)/FN  ♦ PI*. 5 
F(I)  a SIN(FCI)) 

20  CONTINUE 

ON  s FI/SQRT(4.*FI*FI-1.) 

DMsFIl/SQRT(4.*FI  |«FI|.|,) 

A = ON  1 *F  I 
B a DN*FI1 
IRP  a IR  + 1 
IRM  s IR  -t 

CO  50  Ial, NZERO 
U2  CALL  0PDLEGCG,F(I),IR) 

CALL  0RDLEGCGH,F(n,IRM) 

CALL  OPDLEG(GP,F(I),IRP) 

GT  a (A*GP-B*GM)/(F(I)*F(I)-1.) 

FTEHP  s F ( I ) - G/GT 
GTEHP  s F(I)  - FTENP 
F ( I ) a FTEHP 

IF  C ABS(GTEMP)  .GT.XLIM)  GO  TO  «2 
50  CONTINUE 


DO  <jO  Ial, NZERO 

A=2.*(l.-F (I)**2) 

CALL  ORDLEG(B,F(I),IRm) 

e a B*B*FI*FI 
WTCI)3A3(FI-.5)/B 


RAO  ( I ) s ACOSCF(D) 
SIA(I)  « SIN  (RAC  ( I ) ) 
*OCS(I)  ■WT(I)/SIA(I)**2 
60  CONTINUE 

RETLRN 
E 


SUBROUTINE  GGASP2(P,LR/lM,KSM/GG/ILGl/ILATH,C0A#W,KHEM, 

1 AIP,EPSI,IALP,4RKS,*RKU 

* SPECTRAL  ANALYSIS  OF  GAUSSIAN  GRID  GG. 

* PUTS  SPECTRAL  COEFF  INTO  PCLR/LM). 

* IF  GLOBAL  GGs(ILGI,ILATh*2),  OTHERWISE  GGs ( ILG l / HATH ) , 

* LATITUDE  IS  ZERO  AT  LEPT  OF  GRID  AND  POSITIVE  EASTWARD. 

r*  KHEM  0 t GLOBAL,  1 s N HEM  ONLY/  2 s S HE*  ONLY, 

* ksm  dissymmetric#  o«global#  -i=antisymmetric 

* COA(ILATH)  contains  the  COSINES  of  THE  COLATITUDE  (N  TO  3). 

* W(ILATH)  CONTAINS  THE  GAUSSIAN  WEIGHTS  (N  HE*,  N TO  S). 

* ALPCLALP/LH)  IS  A WORK  FIELD  FOR  LEGENDRE  POLYNOMIALS. 

* EPSI  IS  A FIELD  OF  CONSTANTS  THE  SAME  SIZE  AS  ALP. 

* wRKS/WRKL  ARE  SCM/IC*  WORK  ARRAYS  OF  CUGD2)  WORDS. 

* FAST  FOURIER  TRANSFORM  REQUIRES  THAT  ILONG  BE  A POWER  OF  2. 

* WARNING  - KHE*  ANC  KSM  MUST  BE  BOTH  ZERO  OR  BOTH  NON-ZERO. 

* - antisymmetric  fields  analysed  FROM  A hemisphere 

* WILL  ALWAYS  HAVE  A MEAN  OF  ZERO, 


COMPLEX  P(l) 

DIMENSION  GGIILG1, 1)  # ALP  U)  #EPSI  (U/WRKLm 
DIMENSION  COA(l),WCl),WRKS(l) 

* CALCULATE  CONSTANTS  and  set  P to  zero. 

ILGslLGt-1 

ILGHsILG/2 

HAXFsLM-1 

ILP=l 

IF(KSM.LT.O)  ILPsLALp/2d1 
NP=LR*LM 
CO  10  MN*1#NP 
10  P(MNJ«(0.,0.) 

* DO  NORTHERN  HEMISPHERE  IF  ReGUeST£0  (KHEMsO  OP  \) . 

IF (KHEM.EQ.2)  GO  TO  30 
DO  30  IW=1,ILATH 
JRXalLATH+l-IH 
IF(KHEM.EQ.O)  JRXsJRX4IL ath 
SINLATs  COA(IH) 

CALL  ALPNM2(ALP,LALP/LM,SINLAT,EPSI  ) 

IF(KSM.NE.O)  CALL  ALPaS2(ALP»LALP,L*/WRKS) 

CALL  FFWFG2(WRKL,ILGH,GGC1/JRX),ILG1,MAXF,ILG/WRKS,1) 
CALL  FASP2(P,LR,LM,wPKL,ALP(ILP),LALP/W(IH)) 

30  CONTINUE 

* DO  SOUTHERN  HEMISPHERE  IF  REQUESTED  (KHEMsO  OR  2), 
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38  IF(KHEM.EO.l)  GO  TO  50 
CO  40  Ihs1,ILATh 

JRX*IH 

SINLATs-COA (IH) 

CAUL  ALPNM2 ( xtP, L ALP #LM, SIM  AT, EPS  I) 

IF(KS“.NE.O)  CALL  *LPAS2(ALP,LALP,LP,WRKS) 

CALL  FFWFG2(WRKL,ILGH,GG(l»JRX),ILGl,HAXF,ILG,WRKS,n 
CALL  FASP2(P,LP,LH,i*PKL,ALP(ILP)fLALP#‘«(lHn 

40  continue 

* IF  ONLY  ONE  HEuISPHERE  wAS  ANALYSED,  DOUBLE  ALL  COEFF  IN  P, 
50  IF  (KhEM.NE.O)  CALL  SC  0F2  (P , LR , LM  2 ) 

RETLRN 

END 


I 


SUBROUTINE  GWAGD2CQ#D,LRQ,LRD#LM,UGG» VGG# ILGl # IL *TH,CO A , WOC3 , KHEm, 
1 ALP»DAlP*EPSIrLALP,t»RK5fWRKl.) 


* CONVERTS  GAUSSIAN  GRIDS  OF  U,V  IN  UGG, VGG C ILG 1 , NL A T ) . 

* Tp  SPECTRAL  COEFFICIENTS  OF  VOPTICITY  Q(LRQ,LM) 

* AND  DIVERGENCE  D(LRO,LH). 

* IF  GLOPAl,  NLATsILAT.  IF  HEMISPHERIC,  NLATelLATH. 

* NOTE  V IS  ACTUALLY  V*CPS(LAT)/CEARTH  RADIUS).  SAME  FOR  U. 

* KHEM  0 s GLOBAL#  I a N HEM  ONLY,  2 s S HEM  ONLY. 

* CCA(ILATH)  CONTAINS  THE  COSINES  OF  THE  COLATITUDE  (N  TO  S). 

* WOCS(ILATH)  CONTAINS  (GAUSSIAN  wE I GHTS ) /C OS CC OL AT } (N  TO  S). 

* ALP(LAIP,LM)  IS  A WORK  FIELD  FOR  LFGENDRE  POLYNOMIALS, 

* DALP(LALP#LM)  IS  FOP  the  n-5  DERIVATIVES  OF  ALP. 

* EPSI  IS  A FIELD  OF  CONSTANTS  THE  SAME  SIZE  AS  ALP. 

* wfiKS  IS  AN  SCM  WflRK  ARRAY  OF  LENGTH  LP  COMPLEX  HORDS. 

* wRkl  IS  an  LCN  WORK  ARRAY  OF  LENGTH  LR  COMPLEX  WORDS. 

* FAST  FOURIER  TRANSFORM  REQUIRES  THAT  ILONG  BE  A POWER  OF  2. 

COMPLEX  Q(LRQ#  l)#D(lRD»l)#NRKim 
DIMENSION  UGG(lLGi,n#VcG(lLGl,l) 

DIMENSION  ALP(n#CALP(l)#EPSI(n 

DIMENSION  COA(1),WOCS(1),wRkSC1) 

* INITIAL  CONSTANTS.  SFT  G,D  TO  ZERO, 

ILGsILGl-1 

ILGHsilG/2 

ILPsi 

IF (KHEM.NE.O)  lLPaLALP/?*l 

IL AT  sILATh*2 

NLATsILATh 

IF(KHEM.EO.O)  NLAT=ILATh*2 
CALL  SC0F2(Q,LRQ,LM,0) 

CALL  SC0F2(D,LRD,LM#0) 

* PERFORM  THE  CONVERSION  ONE  RP"  AT  A TIME. 

CO  iio  JRs  l , NLAT 


IHsJR 

IF(JR.GT.ILATH)  lHsILAT+1-JP 
IF(KHEM.EO.t)  IHsILATw+i-JR 
SINLATs-COA  C I w ) 

IF (JR.GT.ILATH)  SINLATsCOA  (JH) 

IF(KHEM.EQ.l)  SINLATsCOa(Ih) 
wEIGHTsWQCS(JH) 

* COMPUTE  ALP.DALP  aNC  REORDER  Rows  IF  GRIDS  aRe  HEMISPHERIC. 


CALL  ALP*H*(AlP,LALP,l*,$INlAT,EPSn 

CALL  ALP0«2CDALP,ALP,L*Lp»LH,t:PSn 

IF  (KhtK.Nf .0)  CALL  ALP*S?(  ALP,LALP,LM, WRKS) 

IF  (KHCP.NE.O)  CALL  ALPAS2(0ALP,LALP#LH,wRkS) 

* TERMS  DEPENDING  ON  L. 

CALL  FFWFC2(WRKL, ILGH#UGG(i,JR),ILGl,LM-l#ILG,WRKS,n 
CALL  FASP2(Q,LRQ.L*,wRKL#CALP(ILP),LALP,  WEIGHT) 

DO  22  H=1,LH 

FMEaFLOATfM.i) 

*RKL (M)sCMPLX(-FMS*AIMAG(WRKL(M) ),FMS*REAL(WRKL{M) )) 

22  CONTINUE 

CALL  FASP2CD,LRD,LM,WRKL,ALP»LALP,  WEIGHT) 

* terms  depending  ON  V. 

CALL  FFWFG2(WRKL,ILGN,VGGC1,JR),ILG1,LM-1,ILG,W9KS,1) 

CALI  F ASP2 (D , LRD, LM, wRKL » D ALP #L ALP, -WEIGHT) 

00  2a  Ms  1 , L M 
FMSsFLOAT(M-l) 

WRKL (M)sCMPlX(-FMS*A IMAGtWRKL (M) ),FmS*REAL(WRKL  (M)  ) ) 

2U  CONTINUE 

CALL  FASp2CQ,LRQ,LM,wPKL,ALF(ILP),LALP,  WEIGHT) 
ao  CONTINUE 

* IF  GRIDS  ARE  HEuISPHERIC/  DOUBLE  ALL  C®EFF  IN  G AND  D. 

IF(KHEH.NE.O)  CALL  SC0F2(<J,LRQ/LM,2) 

IF(KHEM.NE.O)  CALL  SC0F2(0,LR0,LM,2) 

RETURN 

END 
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SUBROUTINE  GZFBP  (PH»PEE»PS,TMEAN,PEEhN#PSMN,LA, 

1 LPS,LM#ILEV,RGAS) 

* CALCULATES  GZ  IN  Phi  FROM  0IG  P IN  PEE  FOR  ILEV  LEVELS. 

* IF  MODEL  IS  HEMISPHERIC  PEE#PHIS,PS  APE  SYMMETRIC. 

* EACH  LEVEL  IS  DIMENSIONED  CL*S,Lh). 

* EACH  LEVEL  IS  SEPARATED  BY  LA  COMPLEX  WORDS. 

* PEE  AND  PHI  CAN  BE  EQUl VALENCED . 

COMFLEX  PHI (LA, 15, PEE  CL A, 1), PS (1) 

real  the  an ( i ) , peehn  ( i ) 


DO  30  L31 , ILEv 

DO  20  Msi,LM 
MRs(m-1  )*lRS 
DO  20  Nsl,LRS 
HNshRfN 

20  PHI (MN,L)sPEE(MN,L)  - RGAS*THEAr  CL)*PS(MN) 

30  PHI(1,L)  sPHI(1,L)aPEEMN(L)-RGaS*TMEAN(l)«PSMN 
RETLRN 

end 
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FUNCTION  HTVCCP(T) 


* COMPUTES  *htvocp*  ,thf  ratio  of 

* LATENT  HEAT  OF  VAPORIZATION  OF  HATER  OR  ICE  TO 

* SPECIFIC  HEAT  OF  AIR  AT  CONSTANT  PRESSURE  CP 

* REF  SMITHSONIAN  TA9LES,1R58 

T.GE.T1S  HTVOCPCmATERJ  a ( 3 . 1 52 1 3E +6-2 . 360E t3*T ) /CP 
T.IE.T3S  HTV(*CP(  ICE  ) s (2.B0053E*6-0.167EO*T)/CP 
WITH  LINEAR  INTERPOLATION  IN  BETWEEN 

parameters  computed  in  adjpar 
C0m-hn/hTCP/Tis,T2S, AI,3I,AH,Bh,SLP 

IP(T.GE.TlS)  GO  TO  1 

IFCT.LE.T2S)  GO  TO  ? 

NTVOCP  = SLP*C  CT-TeS)*CAW-gw*T)  ♦ CTlS-T)*(4l-aI*T)  ) 
RETURN 

1 HTVOCP  s Ah-BW*T 
RETURN 

2 HTVOCP  s A I -0  I * T 
RETURN 

ENP 
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SUBROUTINE  INPOC(LC«lLEV,NVAR) 


* PRINTER  output  CONTROL  pop  SPECTRAL  MULTILEVEL  MODEL. 

* LC  « OUTPUT  SWITCHES  FOR  EACH  TIME(NT),  LEVEL(ILEV),  AND  VaRIABL 

* LAB  » ALPHANUMERIC  LABEL  FOR  EACH  VARIABLE  C«  CHARACTERS). 

* cs  s contour  interval  and  scale  factor  for  each  variable. 

* KGGM  8 GG  WINDOW  AND  MAP  SCALE  FOR  EACH  TIME  ( I W , JW , LL , MM , MS  ) . 

* kpsm  r ps  grid  size .pole  and  hap  scale  for  each  time 

* (NI,NJ,IP,JP,M$). 

« maximum  POSSIELE  VALUES, , , ILEVslS,  NVARslo. 

DIMENSION  LC(3,ILEV#I),LCR(3»15) 

COMM  ON/PC OM1/  LRPR,LMPR,KGGH(5,3) ,KPSM(5»3) ,D6  0,DGRW,NHEM 
COMMflN/PC0M2/  LAB(10),CS(2,10) 

DIMENSION  LABX(10),CSX(?,10) 

DATA  CSX/-«00.,l.E+7,-«00.,l.E+B,-20.,l.,12o.,l.,5.,.01,-500.,l., 

1 500,,  100.,  6*0.  t 

DATA  LABX  /«HVORT,RH  DIV,RHTEMR,0H  PHl,RHSFPR,RHpHIS,OM  ES,3*0  / 
DATA  LAST /UHXXXX/ 

* FIRST  COPY  CSX  TO  CS  AND  LABX  TO  LAB, 

CO  15  I s 1 , NVAP 
15  LABCI)8LABX(I) 

DO  17  Isl,NVAR 
DO  17  K=l,2 
17  CS(K,I)sCSX(K,I) 

CS(2,4)sl./Q. 60616 
CS(2,6)sCSC2,«) 

* SET  DEFAULT  VALUE  OF  ALL  SWITCHES  TO  ZERO  (I.E.  NO  OUTPUT). 

DO  20  NVal.NVAR 
DO  20  L=1,ILEV 
DO  20  N T*  1 , 3 
20  LC (NT,L,NV)=0 

* READ  KGGM  AND  KPSM  FROM  CARDS. 


READ (5,5020)  KGGM 
WRITE (6,6020)  KGGM 
READ (5,5020)  KPSM#D60,DGRN,NHEM 
WRITE (6,6030)  KPSM , C6C , DGRW , NHEH 

* READ  CONTROL  CARD*  CHECK  LABEL,  INSERT  IN  CORRECT  PLACE  IN  LC. 

* repeat  until  all  cards  have  been  read  (last  card  contains  xxxx  ) 

26  READ (5,5030)  L ABR , ( (LCR (NT , L ) , N Ts 1 , 3 ) , L e 1 , 1 LE V ) 

IF(LABR.EQ.LAST)  GO  TO  UO 
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DO  35  NVal,NVAR 
IF(LABR.NE.LA0(NV))  go  to  35 
DO  32  l=l,ILEV 
DO  32  NTs  1 # 3 

32  LC(KT#LfNV)sl.CR(NT,L) 

35  CONTINUE 
GO  TO  26 


* WRITE  LC  ON  THE  PRINTER. 


40  00  45  NV*l#NVAP 

45  wRITE(6,6040)  L AB  (N V ) , ( (LC  (N, L , NV ) , Ns l , 3 ) , L« 1 , HE V ) 


RETURN 


5020  F0PHAT(15I3»E10.3#F10.2#I3) 

5030  F0RHAT(A4,15(lX,3in) 

6020  F0RHAT(6H(JKGGMs,3(2X,5I3)) 

6 030  FORMAT (6H  KPSMs , 3 (2X , 5 1 3 ) , 5X , 1 4 HD6  0 , OGR W , NHEMz , E 1 p , 3 , F 1 0 . 2 , 1 5 ) 
6040  F0RHAT(1H0,A4,15H  OITPUT  C ONTROL , 1 0 ( 2X , 3 1 2 )) 

end 


SUBROUTINE  INPTGG(NFl#NF2,DRPAK|WTPAK>CVPAKfILGl>ILATH#KHEN> 

1 KDR,KwT,KCV,KPDR,NPWT,NPCV,GG,GGP,wRKS) 

* GETS  GAUSSIAN  GRICS  OF  DRaG,WaTER-TEMP»  AND  SEA-COVER. 

* FOR  THE  SPECTRAL  MULTILEVEL  MODEL. 

* THEY  ARE  ALSO  WRITTEN  TO  FINE  NF2  FOR  POSSIBLE  RESTART. 

* KDR.ETC  s LOGICAL  SWITCHES  FOR  EACH  VARIABLE. 

* NPDR.ETC  s PACKING  DENSITIES  FOR  E*CH  VARiAELe  In  THE  MODEL. 

* (ALSO  USED  FOR  OUTPUT  PACKING  ON  NF  2 ) , 

* GG, GGP, WRKS  ARE  WORK  FIELDS  USEO  IN  PACKING. 

* INPUT  FIELDS  ON  FILE  NF 1 CAN  BE  IN  any  ORDER#  BUT 

* THEY  SHOULD  OCCUR  AT  THE  BEGINNING  OF  nFI  TO  MINIMIZE  THE 

* EFFECT  OF  THE  REWINDS. 


DIMENSION  ORP AK ( 1 J,wTPAK(i),CVPAK(l) 

DIMENSION  GG(ILG1, l)iGGP(l) 

DIMENSION  WRKS(l) 

LOGICAL  OK.KDR.KWT.KCV 

* /MAPGG/  CONTAINS  HAP  CONTROLS  (SET  IN  THE  MAIN  PGM), 
COMHON/MAPGG/  mggdb.mggwt.mggcv 


IDsQ 

NLAT*ILATH 

IF  (KHEM.EO.O)  NLAT*ILATha2 

* DRAG  FIELD  (CRESSHAN  DRAG  COEFFICIENT  - NOND IHENSIONAL ) . 

IF(.NOT.KDR)  GO  TO  30 
REWIND  NFI 

CALL  RSGGP(DRPaK,IIG1,NLAT,NF1,ID,«H  DR , 1 , OK , GGP , WRKS ) 
CALL  WSGGP(DRPAK,ILG1,NLAT,NF2,ID,«H  DR , 1 , NPCR , GGP , wRKS  ) 
CALL  FCONW2(DRPAK>i00.,l.E5,ILGl,NLAT,l>l,lLGt,NLAT,MGGOR) 

* water  temperature  (DEG  K). 

30  IF  ( .NOT.KWT)  GO  TO  HO 
REWIND  NFI 

CALL  RSGGP(WTPAK,ILG1,NLAT,NF1,ID,RH  WT  , 1 , OK , GGP , WRK S ) 
CALL  WSGGP(WTPAK,ILG1.NLAT,NF2.ID.RH  WT  , 1 , NP W T , GGP , WRK S ) 
CALL  FC0NW2(WTPAK,3.,l.,lLGl,NlAT,l,lflLGl,NLAT,MGGWT) 

* LAND  - SEA  COVER  (FRACTION  3F  WATER  0.  TO  1.). 

«n  IF(.NOT.KCV)  GO  TO  «)R 
REWIND  NFI 
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CALL  RSGGP(CVPAK(ILG1,NLAT,NF1,I0,4H  C V , i , OK , GGP , WRKS ) 

C^LL  wsggp(cvpak,ilgi»nlat,nf2*id#«h  cv»  i»npcv,ggp»'*Rks) 
CALL  FCflNw2(CVPAKf.100.,100.,ILGl ,NLAT,1,1, ILG1,NLAT,MGGCV) 

99  RETURN 

end 
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SUBROUTINE 

1 

2 


INPTSP(NFl,lD»NF2#l»HlS,PS,PHI,P,C»EStLA#lP5fLRAf 

LM,  I lEV  , lEVS,KhEm,  ilG  1 , ILATH,COA,w, WflCS,GG,GGX,GCP, 
AtP,C*Lp#EPSl ,L*LP* WRKS, *RKL) 


* PERFORMS  SPECTRAL  ANALYSIS  OF  GAUSSIAN  GRIDS  (ILGWILAT) 

* FOP  INPUT  TO  TxE  MULTILEVEL  SPECTRAL  M8DEL  • 

* LRS#LRA  ARE  R?"  LENGTHS  FOP  SYMMETRIC  AND  ANTISYMMETRIC 

* spectral  arrays.  They  differ  only  IF  The  model  IS  hemispheric. 


* KMEM  0 3 GLOBAL.  1 C N hem  Only,  2 s s hem  Only.  CGG) 


« INPUT  IS  on  SEQUENTIAL  file  nfi  in  The  FOLLOWING  ORDER, ... 
* Phis, PS, PHI f ILEV), (L,V (ILEV)) ,ES(ILEV)  . 


complex  pHism,psa).PHi(LA,n,p(LA,n,c(LA,n,fs(LA,i) 
DIMENSION  ALPCn,CALP(l)»EPSI(l) 
dimension  coA(n,w(n,«ocsci),HRKsu) 


* GG,GGX  ARE  WORK  FIELDS  FOR  GAUSSIAN  GPIDS  ClLGl.NLAT), 

* GGP  IS  A WORK  FIELC  USED  ONLY  IF  \F1  CONTAINS  PACKED  FlELCS. 

* hFkS,»ROL  ARE  SCM,LCM  "ARK  arrays  OF  ( ILG  + 2)  WORDS. 

C I “E  NS  I ON  GG(n#GGX(l),GGP(n,HRKL(l) 


LOGICAL  OK 

* oltput  packing  ce^sities  cset  in  ^ain  pp*gram). 

COMV'ON/PK^lT/  NPGZ,NPSP,NRm,NPFS 

REMIND  NF  1 
1 

IF(kMEMtE3.0)  KSYMsC 
NLAT=ILATH 

if (khem,EG.O)  NLATsIUiTH*2 

* m*unYaIN  FIELD  (M/SEC ) READ  FRO1*  FILE  NF1. 

* note  - mountains  are  written  to  file  nF2. 

CALL  RSGGP(GG,ILG1,NLAT,NF1,  0,JH  GZS , i , 0 y , GGp  , *PkS  ) 

Call  GGASP2  (PhiS,lRS,Lm,'<HEM,GG,  ILGI,  ILATh,COA,  *,KSY“, 

1 alp,ersi,lalp.-Rks,wrkl) 

CALL  SP AGG2C GG,ILG1,ILATm,COA,k hem, Phis, LRS,LM,kSYM, 

1 ALp,EpSI,LALP,-<RkS,«pkL) 

CALL  wSGGP CGG,  ILG1 ,NLAT ,NF2 , o,4H  G7S  , 1 , NPGZ , GGP , wRkS ) 

* L"r.  Of  Surface  PRESSURE  ('"ILL  IpaRS  5 READ  FPO“  file  NF1. 

* C»*,vEPT  From  millibars  tk  (nEwt^nS/**^)  . 

CALL  RSGGP (GG, ILG1 ,NLAT,NFI , ID,4HLNSP, ! ,Ok,GGP,hRkS) 

CALL  GGASP2C  ®S  ,LRS,L“,NHEu,GG,lLGl,ILATh,COA,M,KSY“, 
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J *LP,EPSI,LALP#wRKS,l»RKl) 

PS ( 1 ) s PSU)+ALHGOOO.)*SQRT(2.) 

* GEOPOTENTIALS  (P/SEC)**2  RF AD  FROH  FILE  NFl. 

DO  250  Lc 1 # ILEV 

CAll  RSGGP(GG,ILGl,NLAT,NFl,lD,aH  GZ, L , OK > GGP , WRkS ) 

CALL  GGASP2(PHln,L)#LRS»LM#KHEM,GG»lLGl/ILATH#C0A/W,KSY^; 

1 alp,epsi#lalp,*rks,*rkl) 

250  CONTINUE 

* «inp  components  (l»v)*coscphi)/(eaRTh  radius)  read  from  file  nfi 

* CONVERT  TO  VORTICITV  (1,/sEC)  AfjD  DIVERGENCE  (l./SEC). 

CO  350  L=1,ILEV 

CALL  RSGGP(  GG, iLGl#NLAT#NFi,IC,4H  U , L # OK , GGP , WRKS ) 

CALL  RSGGP(GGX#ILGl,NL*T,NFlfID,4H  V , L * OK , GGP , *RKS  ) 

CALL  G*AQD2(P(1,L),C (lfL),LRA,LRS,LM,GG,GGX,ILGl,ILATH,C?A,KeCS, 

1 Kt-EP,  ALP,  D ALP,  EPS  I ,LALP,t"RKS,wRKL) 

350  CONTINUE 

* DE*  POINT  DEPRESSIONS  ES  (DEG  C)  rEAD  FROM  FILE  NFl. 

IF  (LEVS.LQ.O)  GO  T"  <?9R 
DO  U50  Nsi.LEVS 
L=(ILEV-LEVS)  ♦ N 

CALL  RSGGP(GG,ILG1,NLAT,NF1,ID,4H  ES,L,Ok,GGP,wRkS) 

CALL  GGAS P2(  ESci,N),LRS,LP,KHEM,GG,lLGl,ILATh,COA,K,KHEM, 

1 ALP.EPSI.LALP^'RKS.wRKL) 

450  CONTINUE 


oqq  RETURN 

end 


SUBROUTINE  INVRSI (PEE«*R#AI»BIfCI,DI*LA,LRS,LH#iLEVfKHEH) 

* THIS  ROUTINE  IS  RECUIREf  TO  IMPLEMENT  THE  SEHI-IMPLICIT 

* ALGORITHM.  THE  TRI-CIAGONAL  MATRIX  DEFINED  BY  AI,BI,  AND  Cl 

* IS  SOLVED  TO  OBTAIN  THE  PEEBAR  FROM  THE  RHS  (Cl)  FOR  EACH 

* HORIZONTAL  MODE.  THE  GENERAL  TRI-DlAGONAL  MATRIX  SOLVER 

* R0SR12  IS  USED  FOR  SOLUTION. 

* IF  MODEL  IS  HEMISPHERIC,  PEEBAR, DI  ARE  SYMMETRIC. 

* EACH  level  IS  dimensioned  (LRS,LM). 

« EACH  LEVEL  IS  SEPARATED  BY  LA  COMPLEX  WORDS, 

* MAXIMUM  VALUE  Of  ILEV  IS  15. 

COMPLEX  PEEBAR(LA,U,DICLA,n 

DIMENSION  Al(iLEV,l),Bl(lLEV,l),Cl(ILtV,n 

DIMENSION  PEBR(15),PERI(15),DIR(15),DII(15),WORk(15) 


DO  <10  Mai  , L M 
DO  <10  Ns  1 , LRS 
ILs(M-|)*LRS*N 
NSsM*n-2 

IF  (Khem.NE.O)  NSsnS+CN-1) 

NSPsnSM 

DO  30  IH*  1 , ILEV 

DIR(IH)  = REAUDI  (IL»  IH)) 

DII(IH)  = AIMAG(DI(IL,IH)) 

30  CONTINUE 

CALL  R0SRt2(PEBR,AI(l,NSP),Bl(l#NSP)#CI(l,NSP),DlR,N0RK,ILEV) 
CAll  R0SR12(PEBI, Ai(l,NSP),HI(l ,NSP)»CI(1,NSP) ,DII,W0RK,  ILEV) 

CO  31  Ihsi.ileV 

PEEPAR(IL,IH)  s CMPLX (PEBR(IH) ,PEBI (IH) ) 

31  CONTINUE 

aO  CONTINUE 

RETURN 

END 
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subroutine  llfxy(dlat,clon,x, y,D6o,dgrw,nhem) 


* CALCULATE  LATITUDE  AND  LONGITUDE  IN  DEGREES  OF  POINT  (X,Y) 

* MEASURED  FROM  THE  POLE.  (LONGITUDE  IS  POSITIVE  EASTWARD). 

a GRID  IS  POLAR  STEREOGRAPHIC  WITH  STANDARD  LATITUDE  AT  60  DEC. 

* AND  GRID  SIZE  D6C  METERS. 

* ZERO  DEGREES  LONGITUDE  IN  THE  GRID  IS  (DGPW)  DEGREES 
a IN  map  COORDINATES. 

a nhem  j c NORTHERN  HEMISPHERE.  NHEm  2 a SOUTHERN  HEMISPHERE. 
a !.866025*(ltSIN60)»  6 . 3 7 l E a6»E AR TH  RADIUS  IN  METERS, 


RE=1.866O25a6.371Ea6/D60 

RE2=RE*a2 

C1  = 180./3,U15R 

A IF  POINT  IS  AT  POLE  set  COOPC  TO  (0.,P0„). 

CLATaRO, 

DLONaO. 

IFCX.EU.O,  .and.  Y.EG.O.)  GO  TO  30 

A CALCULATE  LONGITlCE  IN  map  COORDINATES. 

IFCX.EQ.O.)  DLONaSIGN(PO.fT) 

IF (X.NE.O.)  DL0S=ATAN(Y/X)aC1 
If (X.LT.O.)  DLONaQLON*SlGF (180,,Y) 

* ADJUST  LONGITUDE  FOP  GRID  ORIENTATION. 
DLONrOLON-DGRW 

IF(CL0N.GT.a180.)  CL  ON SDL  ON- 360  . 

IF (CL ON, LT. -180.)  CL0NbDL0Na360  . 

* calculate  latitude. 

R2sXa*2+Yaa 2 

CLATa(RE2-R2)/(RE2+R2) 

CLATs  ASIN(DLAT)aC1 

a CHANGE  SIGNS  IF  IN  SOUTHERN  HEMISPHERE. 

3R  If (NHEM. EG. 2)  DLATa-DLAT 
IF (NHEM, EQ. 2)  DLONa-DLON 
RETURN 
Ef  0 
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SUBROUTINE  LNER(CT,PEET,SDS,CM,PEE*,LA,LRS,IM#I|.£V,DT,RGAS,SM 

* ADO  LINEAR  TERMS  OF  RHS  TO  PEET,SDS. 

PARAMETER  SIMV  s 15,  IM  = 5,  SIR  = 25,  IRM  a 2 1*  5 1 R ♦ 1 

* IF  MODEL  IS  HEMISPHERIC,  ALL  FIELDS  ARE  SYMMETRIC, 

* EACH  LEVEL  IS  DIMENSIONED  (LRS,LM). 

* EACH  LEVEL  IS  separated  BY  la  complex  words. 

COMPLEX  CT(LA»l)#PFET(LA»l),SDS(LA#l)#CH(LA#l)#PEEH(LA#l) 
COMPLEX  TEmP(SIHV) 

real  MI,MII,MIIM1 ,mi,«2,MP,hPmi,mm,MW,MPI,M2M1 

COmmbn  / NEWMat  / MI(IM,IH),mh(Im,iM),MIIM1(IM,IM),mi(IM,IM), 

* M2CIM,IM),mP(Im,IM),MPM1(Im,IM),MMCIM,Im), 

* mi*cim(1m),mpicim,im,irm),m2m1(Im,im) 
DIMENSION  SF(1) 

ILEVMsILEV-1 

D P 30  Ms  1 f lm 
DO  30  Nsl,LRS 
ILs(M-1)*LRS+N 

DO  20  Ih«1,ILEV 

SCS(IL#IH)  = *SDS(IL#IH)  - PT*CT(IL#IH)  - Cm(IL,IH) 

20  CONTINUE 

DO  2a  IHsl,ILEV 
TEmpcihjso.O 
DO  2U  IK  = l , ILEV 

24  Temp (IH)sTEMP (IH)  ♦ MPM1(IK,IH)*PEET(IL,IK> 
no  25  IH=l , ILEV 

25  TEMP(IH)  s DT  a TEuP(IH) 

DO  26  IH*1,ILEV 

26  PFET(IL,IH)  = TEMP { Ih)  ♦ PEEM(IL,IH) 

30  continue 

RE  TURN 
END 

SUBROUTINE  MaTMLT (X1,X2»X3,N) 

DIMENSION  X1(N,N),X2CN,N),X3(N,N) 

DO  1 Js  1 , N 
DO  1 I a 1 , N 
Xt (I, J)so.O 
DO  1 K s 1 , N 

1 XI  (I,J)BX1 (I,J)+X2(I,K)aX3(K,J) 

RETURN 

END 
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SUBROUTINE  HH ANL W(PT,CT,PrET,SDS,TOUM,EST,ESDOH, PRESS, L4# 
i pltf,pvtf,tutf,tvtf,peetf,scsf*ef,tf,$usf,svsf, 

ESTF,ESE,PPESSF, ILH,ILM,L«S,LRA,LM, 

ALP, D ALP, L alp, hRKS,^L,WOCSL,ILONG,KHEm,ILEV, LEVS) 

* CONVERTS  ILONG  GRID  values  TO  FOURIER  COEFF  ThEN  CALCULATES 

* CONTRIBUTIONS  t 0 SPECTRAL  FIELOS  for  one  GAUSSIAN  LATITUDE. 

* MOISTURE  VAPiABLES  OMITTED  IF  LEVS  = 0. 

* IF  THE  MODEL  IS  HEMISPHERIC  P T IS  ANTISYMMETRIC. 

* ALL  OTHER  SPECTRAL  FIELDS  ARE  SYMMETRIC. 

* alpclalp,lm)  contains  legendre  polynomials  for  one  latitude. 

* DAl.P(L*lP,LM)  contains  N-S  DERIVATIVE  of  Alp. 

* WRKS  IS  AN  SCM  WORK  ARRAY  USED  BY  THE  FAST  FOURIER  TRANSFORM. 

COMPLEX  PT(LA,n,CT(LA,n,PEET(LA,l),SDS(LA,n 
COMPLEX  ESTClA,  n,TCUM(LA,n,ESDUM(LA,l),pPESSCl) 

Complex  PUTF(lLH,n,PVTF(ILH,n,TUTF(ILH,t),TVTF(ILH,n 
complex  peetf cilh, d,sdsf cilh, i j ,ef (Ilh, 1),tf cilh, d 
complex  SUSP  ( ILH,  n,  S VSF  ( ILH,  n,  ESTF  ( ILH,  t),ESF(  ilh,  1) 

COMPLEX  PRESSFC1) 

CIMfNSIPN  DALPm,4LPCn»wRKSCU 

* IF  MODEL  IS  HEMISPHERIC,  THE  SYMMETRIC  AND  ANTISYMMETRIC 

* COEFF  IN  THE  ROWS  OF  ALP,DALP  HAVE  BEEN  SEPARATED. 

ilevp=ilev+i 

ILP=i 

IF  CKHEM.Nf.O)  ilp=lalp/<j+i 

IR=LM-1 


* ALSO,  WI  AND  WOCSI  are  DOUBLED  to  ACCOUNT  FOR  THE  HISSING  HEM. 


wIswl 

IF (KHEM.NE.O)  WIsWL+wL 
W PC  S I =W  0C  SL 

IF(KHEM.NE.O)  W?CSI=wCCSL+wOCSL 

* CONVERT  GRID  POINT  VALUES  TO  FOURIER  COEFF. 

* ilh, ilm=Real, complex  dimensions  of  peetf»etc  ulm=2*ilh). 

CALL  FF WFG2 (PEETF, ILH, peetf, ILM,IR,ILONG,WRKS,lLEV) 

CALL  FFWFG2C  TUTF,ILW,  TUTF , ILM , I R , ILONG , WRKS , IlEV ) 

CALL  FFWFG2 ( TVTF,ILH,  T V TF , I LM , IR , ILONG , WRKS , ILE V ) 

CALL  FFWFG2C  PUTF,ILH,  PUTF , ILM , IR , IL ONG , WRKS , IlEV ) 

CALL  FFWFG2(  PVTF,ILH,  P VTF , ILM , I R , I LONG  , WRKS , I LE V ) 

CALL  FFWFG2  ( SDSF,ILH,  SDSF , ILM , IR , IL ONG , WRKS , I LE V ) 

CALL  FFWFG2(  TF,  ILH,  TF , ILM , I R , IL ONG , WRK S , ILE VP ) 
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CALL  FFWFG2(PRESSF,ILH,PRe;SSF,ILM,IR,  IL0NG,WRKS,1 ) 
* MOISTURE  VARIABLES  (OMITTED  IF  LEVSsO). 


IF(LEVS.EO,0)  GO  TO  13 

CALL  FFWFG2C  SUSF,RH,  SUSF  , ILM  # I R , ILONG , WRKS , LE  VS ) 
CALL  FFWFG2C  SVSF,ILH,  S VSF , ILM , I R , ILONG , WRKS , LEVS ) 
CALL  FF*FG2(  ESTF,ILH,  ESTF, ILM, IR,IL0NG#WRK3, LEVS) 
CALL  FFWFG2C  ESF,  ILM,  ESF , ILM , I R , ILONG , WRKS , LEVS ) 


* FOURIER  CONTRIBUTIONS  AT  ONE  LAT  CONVERTED  TO  SPECTRAL  COEFF. 

* FOR  VORTICITV  ANO  01 VERGENCE-TVPE  TERMS  OF  PT,CT,PEET,EST , 

* CALCULATION  op  NORTH-SOUTH  DERIVATIVE  TERMS. 

13  ro  20  L=1 , ILEV 

CALI  FASP2(PEET(l,L),LRS,LM,TVTF(t,L)#DALP  ,LALP,-NOCSI) 

call  FASP2C  PT(1,L),LRA,LM,PVTF(1,L),DALP(ILP),LALP,  *3CSI) 

CALL  FASP2C  CT(1,L),LRS,LM,PUTF(i,l),CALP  ,LALP,  wOCSI) 

20  CONTINUE 

* MOISTURE  VARIABLES  ("MjTTEC  IF  LEVSsO) 

IF (LEVS.EQ.O)  GO  TO  30 
DO  21  L*1,LEVS 

CALL  FASP2(  EST(1,L),LRS,LM,SVSF(1,L),DALP,LALP,  NOCSI) 

21  CONTINUE 

* EAST  - wpST  DERIVATIVE  TERMS  CALCULATED 

30  DO  3fc  Lsl, ILEV 
FSO  s mQCS I X 

CO  32  M- 1 , LM 

ei  = FLnAT(H-l)*FSG 

SCR  s - BI*AIMAG(TUTF(M,L)) 

SCI  s BI*PFAL (TUTF  (M,l  )) 

PEETF(M,L)  s PEETF'(M,l)  ♦ CMPLX(SCR#SCI) 

32  CONTINUE 

DO  33  MslRM 

ei  3 floatch-1)*fsg 

SCR  s BI*AIMAG(PIJTF  (M,L) ) 

SCI  S -BI»REAL(PUTF(M,l)) 

PUTF(M,l)  5 CMPLX(SCP,SCI) 

33  CONTINUE 

DO  in  Ms  1 * LM 

ei  s fLoat(m-1)*fsg 

SCR  S -PI*AIMAG(PVTF(M,L)) 


I - 73 


i 


k 


SCI  S BI*REAL(PVTF(M,D) 

PVTF(M.t)  “ CMPLX(SCP#3CI) 

34  continue 

CALL  FASP2I  PT(l,L)#LRA#LH,PUTF(l»L)»  ALP  t ILP ) ,LALP , 1*1) 
CALL  FASP2C  CT(1,L)#LRS#LM,PVTF(1,L)#  *LP#L*LP#  MX ) 

J6  CONTINUE 

* MOISTURE  VARIABLES  (OMITTED  IF  LEVS«0) 

IF  (LEVS.EQ.O)  GO  TO  49 
DO  <16  L=1 »LEVS 
F SO  s WOCSI/WI 

DO  <J1  Mat,LM 

6 1 s FLOAT (M«l ) *FSG 

SCR  = BI»AIMAG(SUSF(M,D) 

SCI  = -BI*REAL(SUSF(M,L)) 

ESTF(M,L)  * ESTF(M,L)  ♦ CMPLX(SCR,SCI) 

<11  CONTINUE 

<16  CONTINUE 

* ADD  THE  REMAINING  TERMS. 

<19  CO  50  Lsl,ILEV 

CALL  FASP2(PEET(1,L)»LRS»LM#PE:ETFC1,L)»ALP#LALP#WI) 

CALL  FASP2C  SDS ( l , L ) ,LRS, LM , SDSF(l,L)»ALP»LALP,wI) 

CALL  FASP2(TDUM(1,L)*LRS,LM,  TF ( 1 ,L ) , ALP,L ALP , *1) 

50  CONTINUE 

CALL  F ASP2 ( TDUM ( 1, ILE VP) , LRS, LM, TF Cl, ILE VP), ALP, L ALP, wl) 
CALL  FASP2(PRESS,LRS,LM,PRESSF,ALP,LALP,*I) 

* moisture  variables  comittec  if  levs=o). 

IF (LEVS.EQ.O)  GO  TO  49 
DO  52  L=1,LEVS 

CALL  FASP2(  EST(1,L),LRS,LM,  ESTF(1,L),ALP,LALP,RI) 

CALL  FASP2(ESDUM(i,L),LRS,LM,ESF(l,L),ALP,LALP»Wl) 

52  CONTINUE 

99  RETURN 
END 
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SUBROUTINE  mheXPWCPF,CF,TF*ESF,UF, VF,PSDLF,PSDPF/PReSSF,ILH.ILM, 

1 P»C»T,ES,U,V,P5,LA*LAW,LRS,LRA,LRU,LRV,LM,ILEV*LEVS, 

2 ILONG,KMEM,ALP.DALP,LALP,wRKS) 

* CONVERTS  ARRAYS  OF  SPECTRAL  COEFF  TO  FOURIER  CO EPF 

* AND  THEN  TO  ILONG  GRID  VALUES  FOR  ONE  GAUSSIAN  LATITUDE. 

* IF  MODEL  IS  HEMISPHERIC  C,T,E5,U,PS  ARE  SYMMETRIC, 

* P,V  ARE  ANTISYMMETRIC. 

* LEVELS  OF  U,V  ARE  SEPARATED  BY  LAW  COMPLEX  WORDS. 

* ALL  OTHER  VARIABLES  USE  LA  COMPLEX  WORDS. 

* ALP(LALP»LM)  CONTAINS  LEGENDRE  POLYNOMIALS  FOR  ONE  LATITUDE. 

* DALP(LALP#LM)  CONTAINS  N-S  DERIVATIVE  OF  ALP. 

* WRKS  IS  AN  SCM  WORK  ARRAY  USED  BY  THE  FAST  FOURIER  TRANSFORM. 

COMPLEX  P(LA,l),C(LA,l),T(LAft),ES(LA,l) 

COMPLEX  U(LAW, 1),V(L4W,  1),PSC1) 

COMPLEX  PF(ILH,n,CF(ILH#l),TF(ILH,l),FSF(ILH,l) 

COMPLEX  UF(lLH,l),VF(ILH»n 
COMPLEX  PSDLF(l),PSCPF(l),PRESSF(n 

DIMENSION  ALPCIJ.DALPCJ) 

DIMENSION  WRKS(l) 

* IF  MODEL  IS  HEMISPHERIC,  THE  SYMMETRIC  AND  ANTISYMMETRIC 

* COEFF  IN  THE  ROWS  *F  ALP,DALP  HAVE  BEEN  SEPARATED. 

ILEVPsILEV+1 

ILP'l 

IF(KHEH.ne.O)  ILPsLALP/2+1 
IRsLM-J 


* FOURIER  COEFF  OF  P,C,T,U,V. 

DO  70  L= 1 , ILE V 

CALL  SPAF2(PF(1,LJ,P(1,L)»LRA,LM,ALP(ILP)#LALP) 

CALL  SPAF2(CF(1,L),C(1,L)#LRS,LM,ALP,LALP) 

CALL  SPAF2(TF(1,L),T(1,L),LRS,LM,ALP.LALP) 

CALL  SPAF2(UFU,L),L(l,L),l.RU,LM,ALP,LALP) 

CALL  SPAF2(VF(l,L),V(l,L),LRV,LMf ALP(ILP),LALP) 

70  CONTINUE 

CALL  SPAF2(TF(i,ILEVP),T(t,ILEVPj,LRS,LH,ALP,LALP) 

* FOURIER  COEFF  OF  PS  AND  ITS  N-S  AND  E-w  DERIVATIVES. 

CALL  SPAF2(PRESSF,PS,LRS,LM,ALP,LALP) 

CALL  SPAF2C  PSDPF,PS,LRS,LM,DALP,LALP) 

PSDLF(1)*(0.,0.) 
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CO  72  n«2,LH 
fMS*Fl84T(M-t ) 

RPSs  REAKPRESSF  (M)) 

CPSs*IM*G(PR£SSF(M)) 

PSOLF (HjsC^PUXf-FMStCPS,  F*S*HPS5 
72  CONTINUE 

• CONVERT  FOURIER  C*fFF  TO  GRID  POINT  VALUES. 

CALL  FFGP*2(PF,IL%PF,ILH,IR#I10NG,-RKS,ILEV) 

CALL  FFGFW2(CF,ILf',CF#lLH,IR,IL0NG#NRKSf  ILEV) 

CALL  FFGF*(2(TF,ILm*TF,Ilh#IR#IL8NG»WRkS.ILEVP) 

CALL  FFGFK2(UF,ILH,LF,lL'-,IR,IL0NG,i<RKS#lLEV) 

CALL  FFGP«2(VF,  IL*',  VF,IL^#IP#ILONG#wRkS#ILEV) 

C*LL  FFGFh2(  PSKLF.ILH,  PSDLf  , ILW , I * t IlONG#  HR*  S , 1 ) 
CALL  FFGFW2J  PSCBF,ILU,  PSCPF  , ILH , I R , ILONG , *RKS , J ) 
CALL  FFGFH2(PRESSF,ILm,PRESSF,  IL>-,IP#I10NG,kRkS,1) 

* -oistlre  variables  (omitted  if  levs  *o). 

IF(LEVS.EG.O)  GO  TP  RR 
CO  90  Lsl.LEVS 

CALL  SPAF2(ESF(i#L)iES(l.L),LPS#LH,ALP*LALP) 

RO  CONTINUE 

call  FFGF-2CESF,Il‘',ESF,  ILH,  IR,  ILONG.wRkS.LEVS) 

RR  RETlRN 
END 
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SUBROUTINE  MTX IN V ( * , Z , N ) 


* FINOS  THE  INVERSE  OF  MATRIX  Z(N,N)  BY  THE  EXCHANGE  METHOD. 

* MAX  VALUE  OF  N IS  15.  RESULT  IS  PUT  IN  A(N,n). 

DIMENSION  A(N,N),Z(N*N) 

DIMENSION  IX(15),ICC15) 


DO  10  J=1,N 
I X ( J ) e 0 
CO  10  I a 1 , N 
10  A(I, J)aZ(I.J) 

DO  A2  Ksl,N 
B = 0.0 

DO  2 Js 1 , N 

IF ( I X ( J J ,GT.O)  GO  TO  2 
S = ABS(A(K,J)) 

IF(S.LE.B)  GO  TO  2 
B = S 
L = J 

2 CONTINUE 
IX ( L ) =K 

DO  a Jsl,N 
D=A(K,J)/A(K,L) 

IF(J.EQ.L)  go  to  4 
DO  3 1=1, N 

3 A(I,J)sA(I,J)«D*A(I,L) 
A(K,J)s-D 

a continue 

D = 1»0/A(K,L) 

CO  «1  1 = 1, N 
«1  A(I,L)  = 0* A ( I , L ) 

A(K,L)  = 0 
a2  CONTINUE 

• REORDER  ROWS  AND  COLUMNS. 

co  as  i=i, n 
as  ICCIX(T) )=I 
CO  70  Ksl,N 

IF(IX(K).EQ.K)  GO  TO  tO 
DO  51  L=1,N 

IF (IX(L3.E0.k)  GO  TO  53 
51  CONTINUE 
53  DO  55  1 = 1, N 

CsA(I,K) 

A ( I ,K)*A (I ,L) 

55  A(I,L)=D 
IX(LJslXCK) 
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I X (K ) sK 

60  IFdC(K).EO.K)  GP  T"  70 
DO  61  L*1 » N 

IF(IC(L).EQ,K)  GO  TO  63 

61  CONTINUE 

63  DO  65  Jcl,N 
0»A(K,J) 

A(K,J)sA(1.,J) 

65  A(L,J)*D 
IC(L)sIC(K) 

IC (K)sK 
70  CONTINUE 

RETURN 

END 


SUBROUTINE  NEWBP (PEE ,PEE*,PEFBAR »L A ,LRS ,LM, ILE V, FPEE, IFDIFF) 

* PERFORMS  ONE  TIMESTEP  FOP  PEE  FROM  PEEM,PEEBAR. 

* if  model  is  hemispheric  pee»reem/PeebaR  are  symmetric. 

* EACH  LEVEL  IS  DIMENSIONED  (LRS.LM). 

* EACH  LEVEL  IS  SEPARATED  BY  LA  COMPLEX  WORDS. 

* IFDIFF...l*FOREWARD  TIMESTEP.  OaCENTERED  TIMeSTEP. 

* FPEE  IS  A TIME  FILTER  For  PEE. 

COMPLEX  PEECLA,n,PEFMCLA,l),PEEBAR(LA,n 
complex  PEEP 

DO  30  LslflLEV 

DO  20  m s l , L M 
MRs(M«l }*LRS 
DO  20  Nsl.LRS 
MNsMR+N 

PEEPs2.*PEEBAR(MN,L)-PEEM(MN,L) 

REE(MN,L)sPEE(MN,L)  ♦ FPEEA(PEEP+PEEM(MN,L)-2.*PEE(MN,L)) 
IF(IFDIFF.EQ.O)  PEEM(MN,L)=PEE(HN,L) 

20  PEE(MN,L)sP£EP 

30  CONTINUE 

retlrn 

END 


SUBROUTINE  NEWC (C,CH*CT,PEEBAR,LA,LRS,LM,ILEV#ASQ, 

1 DIFU$D,DT,FC,IFDlFF,KHEM) 

* PERFORMS  ONE  TP*ESTEP  FOP  DIVERGENCE  (C)  FROM  CM,CT,PEEBAR. 

* IF  MODEL  is  hemispheric  c.cm»ct,peebar  are  symmetric. 

* EACH  level  IS  DIMENSIONED  CL«S,LH>. 

* EACH  LEVEL  IS  SEPARATED  by  la  COMPLEX  WORDS. 

* DIFUSR  a HORIZONTAL  DIFFUSION  OF  DIVERGENCE. 

* OT  IS  The  LENGTH  OF  The  JUMP  (DEET  if  CENTERED/  DEET/2  if  FWD). 

* FC  IS  A TIME  FILTER  for  c. 

* IFDIFF,..lsF0REW4fi0  TIMESTE P,  0*CENTERED  TIMESTEP. 

* KHEMao  FOR  GLOBAL,  1 OR  2 FOR  HEMISPHERIC, 

COMPLEX  C(LA,l),CM(LA,l),CT(LA,n,PEE3AR(LA,n 
COMPLEX  CP 

FACTD=1,/(1.*2.*CT*DIFUSD) 
no  30  Lel,ILEV 


DO  20  M = 1 , L M 

MRa ( M« 1 ) *LRS 

DO  20  N=l,LRS 
MNaMR*N 

NSa(M-l)*(N-l) 

IF(KHEM.NE.O)  NSaNS+(N-l) 

FNSlsFLOAT(NS*{NS+l)) 

CPa2.*DT*(FNSl*PEEBAR(MM,L)/ASG  ♦ CT(MN,L)>  * CM(MN,L) 
CPsCP*FACTD 

C CMN,L)sC  (MN,L)  ♦ FC*(CP*CM(MN,L)-2.*C(MN#D) 
IF(IFOIFF.EQ.O)  CM(MN,L)sC(MN,L) 

C (MN,l)sCP 

20  continue 

30  CONTINUE 

RETIRN 
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SUBROUTINE  NEWES(ES,ESM,E$T#U#LRS#l".LEVS,ASQ, 

I DIFUSS, DT,FS#IFDIFF,KHEM) 

* MULTILEVEL  SPECTRAL  MODEL  TIMESTEP  SUBROUTINE. 

* OBTAINS  VALUES  AT  THE  NEXT  TIMESTFP  OF  DEW-POINT  DEPRESSION'  (ES) 

* from  the  tendencies  cest)  and  the  previous  values  (esmj. 

* IF  model  IS  HEMISPHERIC  ES,ESM,eST  ARE  SYMMETRIC. 

* each  level  is  dimensioned  clrs,lm). 

* EACH  level  is  separated  BY  la  COMPLEX  MORDS. 

* levs  s number  of  moisture  levels  in  THE  MODEL. 

* TO  OMIT  MOISTURE  CALCULATIONS  SET  LE^S  s 0. 

* DIFUSS  = HORIZONTAL  DIFFUSION  OF  ES. 

* DT  is  the  LENGTH  OF  the  JUMP  (DEET  if  CENTERED#  DEFT/2  IF  FAD). 

* FS  s TIME  FILTER  FOR  ES. 

* IFDIFF,,.1=F0REWARD  TIMESTEP,  (^CENTERED  TIMeSTEP. 

* KHEMso  FOR  GLOBAL#  1 OR  2 FOR  HEMISPHERIC. 

COMPLEX  ES(LA,n,EST(LA,l),ESM(L4,l) 

COMPLEX  ESP 

IF(LEVS.EQ.O)  RETURN 
F ACTSsDlPUSS/ASQ 

CO  40  Ms  1 , LM 
DO  40  Nsl,LRS 
IL=(M-I)*LRS+N 
NSsM»N-2 

IF (KHEM.NE.O)  NS»NS+(N-1) 

FNSl=FLOAT(NS*(NS*m 
28  DIFLPS*FACTS*FNS1 

DO  30  IH=1,LEVS 

ESPsFSMUL#  IM)+2.*DT*(EST(IL#  IH)-DIFLPS*ESM(IL#  IH)) 

ES(IL,IH)sES(IL,IH)  ♦ FS*CESP+r.SM(IL,IH)-2,*ES(IL,lM) 

IF (IFDIFF.E3.0J  ESM ( IL , IH ) sf S ( IL , I* ) 

FSCIL, IM)=ESP 
30  CONTINUE 

40  CONTINUE 

RETURN 

END 
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SUBROUTINE  NE*p  (P,PM,PT,LA#LRA#LM,ILEV,DT,FP,IfDIFF> 

* PERFORMS  ONE  TIMESTEP  FOR  VORTICITV  (P)  FROM  PM  AND  PT. 

* IF  MODEL  IS  HEMISPHERIC  P#PM,PT  ARE  ANTISYMMETRIC 

* EACH  LEVEL  IS  DIMENSIONED  (LPAfLM). 

* EACH  LEVEL  IS  SEPARATED  By  L*  COMPLEX  mORDS. 

* Dt  is  The  length  OF  the  JUMP  (DEET  if  CENTERED#  DEET/2  IF  FMD). 

* FP  is  A TIME  FILTER  For  P. 

* IFPIFF. .. lsFOPEWABC  TIMESTEP,  OsCENTEREO  TImeSTEP. 

COMPLEX  P(LA,n,PM(LA,l),PT(LA,l) 

complex  pp 
C m 30  Ls 1 # ILE  V 
C?  2 n m-i,ln 

HR: ) * L R A 

CO  20  Ns  1 , LR * 

M r,  s M 9 ♦ N 

PP«FU(“N,L)  ♦ 2.*DT«PT(mN,L) 

P(MN,l)sP(MN,L)  ♦ FP*(PP*PM(Mn#L)“2,*P(mn>L)) 

IF(IFOIFF.EQ.O)  Pm(MN,L)*P(MN,L) 

P (mn#l ) sPP 

20  continue 

30  CONTINUE 

RETURN 

END 
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SUBROUTINE  newps(ps,psm,peet,peebar,la,lrs,lr»ilev,ambda,sf,avert, 

1 RGAS,DT,FpS»IFDlFF) 


PARAMETER  IMs5,  IRH=2*25+1 

* PERFORMS  ONE  TIMESTEP  FOR  L N C SURF  ACE  PRESSURE)  IN  pS 

* FROM  p$m,peet  anc  peebar. 

* IF  HOPFL  IS  HEMISPHERIC  PS , PSM , PEE T , PEEP AR  ARE  SYMMETRIC. 

* EACH  LEVEL  IS  dimensioned  (LRS,Lh) • 

* EACH  LEVEL  IS  SEPARATED  BY  L*  COMPLEX  WORDS. 

* [>T  IS  The  length  OF  the  jump  cdeet  if  centered,  DEET/2  IF  FWD). 

* FPS  IS  A TIME  FILTER  FOR  PS. 

* IFDIFF...lsFOREWARD  TIMESTE",  OaCENTERED  TIMeSTEP. 
complex  ps(1),pshci),peetcla,i),peebar(la,1) 

DIMENSION  AMBDA ( 1 ) , SF  ( I ) 

COMPLEX  PSP, TEMP ( 15  ) 

REAL  mi, mii, mii Mt, Ml, m2, HP, MPMl, mm, pw,H2Ml 

COMMON  / NEWMAT  / Ml(IMfIM)/HII(IM,IM),MIIMl(IM,IM), 

* m1(IM,IM),M2CIM,im),MP(IM,IM),mpmhIH,IM), 

* mm(im,Im),mw(Im,II'),RPICI*,IR,IRm),m2micim,IM) 


ILEVMsILEV-1 

DO  20  Ma l , L m 
MR= (M-l) *LRS 
00  20  N=1,LRS 
IL=MR*N 

PSPsO.O 

DO  in  Im=1,IlEV 

10  PSPsPSP+(PEET (IL,IH) -PEEBAR (IL,IH) )*M2Mi  (Ih,ILEV) 
PSP  s PSM(IL)  +2.*PSP 

PS(IL)=PS(IL)+FPS*(PSP+PSM(IL)-2.*PS(IL)) 
IF(IFOIFF.EQ.O)  PSMdL)aPS(IL) 

PS(IL)=PSP 

20  CONTINUE 

RETURN 

END 
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SUBROUTINE  OROLEG(SX,COA#lR) 


* This  ROUTINE  IS  A SUBSET  OF  BELOUSOVS  ALGORITHM 

* USED  TO  CALCULATE  ORDINARY  LEGENDRE  POLYNOMIALS, 

* SX  s LEGENDRE  POLYNOMIAL  EVALUATED  AT  CO* 

* COA  = COSINE  OF  COLATITUDE 

* IR  a WAVE  NUMBER 


pi  = 3.i«i5<?26535B<>e 

SQR2sSQRT(2t) 

I«PP  s IR  ♦ 1 
IRPPM  a I RPP  . l 
DELTA  s ACOS(COA) 

S I A s SIN (CELT  A ) 

THETAsOELTA 

ClsSQR2 

DO  20  Ns  1 » IRPPM 
FNsFLOAT(N) 

FN232,*FN 

FN2SQsFn2*FN2 

ClsCt*  SQRTC1.0-1.0/FN2SQ) 

20  CONTINUE 

NsIRPPM 
ANGsFN«THETA 
S 1 =0 , 0 
C«*1.0 
A = -l  .0 

eso.o 

MsMl 

DC  2 T KKaj,Nl,2 
K=KK- 1 

IF  (K.EC.N)  Ci|s0.5*C« 

SlaSlfCU*  COS(ANG) 

AaA+2.0 

PsB+1.0 

FKaFLOAT(K) 

A^G3THETA*(FN-FK-2.0) 

C4=(A*(FN»B  + 1 , 0 ) / ( B A (FN2-A)))*Ca 
27  CONTINUE 


SUBROUTINE  PBLMAT(RGAS,RGOCP,S,SH,SF,SHF,AMBDA,TMEAN,GRAV, 

* GAMMA, ILEV) 

PARAMETER  ILs5,  I»  = ILM,  IRSs25,  IRMs2*IRS+l 

THIS  ROUTINE  SETS  UP  THE  maTRICIES  TO  BE  USED  IN  THE 
VERTICAL  DIFFERENCING  SCHEME 

IL  IS  THE  number  Of  LEVELS  - Same  as  JILV  in  NRlCMOOIFIEC) 
CANADIAN  M3DEL 

REAL  S(IL),SH(IL),SFCIL),SHF(IL),AMBDA(IL),TMEAN(Il) 

REAL  MI,MII,MIIMi,Ml,M2,MP,MPMi,M,MW,MPI,M2Mt 
COMMON  / NEWMAT  / MI(IL,IL),MII(IL,IL),MIIMI(IL,IL), 

* H1(IL,IL),M2(IL,IL),MP(IL,IL),HPM1  (IL.ILJ, 

a MCIL,IL),M«(IL,IL),MPI(IL,IL,IRM), 

* H2M1(IL»IL) 


3 

12 


ILmcIL-1 

CNsS(IL)AA(RGAS*GAMMA/GRAV) 

CN  * 1,  / CN 

DO  12  K = 1,  I fi M 

DO  3 J = 1,  IL 

DO  3 I s 1,  il 

MP I ( I , J , K ) s 0,0 

MW(I, JJsO.O 

M(I, JJsO.O 

MPMl (I, JJsO.O 

MP(I, JJsO.O 

M2(I, JJSO.O 

Ml (I, JJsO.O 

MIIM1(I,JJ  s 0.0 

Mil  (I#J)  = 0,0 

M I ( I , J J s 0.0 

CONTINUE 


SET  UP  THE  HaTRICIES 

DO  2 I s 1,  ilm 
MII(I  + 1,U  = 1.0 
2 MII(I, I)  : 1,0 

MIICILfIL)  s CN  ♦ 1. 

CALL  MTXINV(MIIM1,MII,IL) 

DO  5 I s i,  ilm 
M I ( I ♦ 1 , 1 ) s 1 , /SF  ( I ) 

5 M I ( I , I ) s (-1.)  / SF(I) 

MI ( IL , IL ) 3 c-l.J  / SF(IL) 
CALL  maTmlT(MP,mi,mIIHi,ilj 
C0NSTs2./RGAS 
DO  u J»1 , IL 
DO  « 1*1, IL 

« MP(I,JJ=C0NST*MP(I,JJ 


I 


B5 


r — ==-  1 


C*LL  MTXINV(MPM,MP,ID 
09  1 !*2,IL 

M1(I, I)  = C-t.)  / SHF(I-l) 

7 Mld-1,1)  » 1.  / SHF(I-l) 

HI  Cl* 1 > = (-1.)  / SH(1) 

CALL  MTXINV(MW,Ml,IL) 

00  6 J ■ 1,  IL 
00  6 I « 1,  IL 

IFd.EQ.l.AND.J.EQ.l)  GO  TO  6 

MW(I,J)  s SCJ)  * MW ( I , J ) 

6 CONTINUE 

DO  13  Jsl.IL 
DO  13  1=1, IL 

IF(A0S(MW(I,J)),LT,1.E»O7)  MW(I,J)s.O 
13  CONTINUE 

00  8 I s 1,  IL 

8 M2 ( I , I ) = 0.5  * AMnOA(I) 

DO  18  I = 2,  IL 

18  M2(I-1,I)  s 0.5  * AMEDAd-1) 

DO  o 1=2,  ILM 

*>  M2(IL,I)  = M2(IL,I) 

* - 0,5  * (SH(I)*AMBDAd)+SH(I-l)*AMBDA(I.l)) 

* ♦ PGOCP  * TMEAN(I) 

M2(IL,1)  * M2 ( IL , 1 ) - O.5*SHC1)*AM0OA(1)  ♦ PG"CP*TMEAN ( i ) 
M2(IL,IL)  = M2(IL,IL) 

* -O,5*(SH(ILM)*AMeDA(ILM)+AM0OA(lL)) 

* t RG5CP  * TMEAN(IL) 

CALL  maTMlT(m1,M2,MPM1,IL) 

DO  10  1 = 1, IL 

1«  Ml  (I,  I)=Mj (1#I)-RGaS*TMEAN(I) 

CALL  MTXINVfM2Ml,Mt,IL) 

DO  10  I = 1,  IL 
SUM  = 0.0 
DO  11  J = 1,  IL 

11  SUM  = SUM  + TMEAN(J)  * MP(J#i) 

SUM  s SUM  « RG AS 

10  M2 ( IL , I ) = Mg ( IL , I ) • SUM 

CALL  maTMLT(mi,mw,H2,IL) 

CALL  MATMLT(M,M1,MPM1,IL) 

ENO 


I 
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SUBROUTINE  PC0r2($C#lP»LM,NPR,MPR) 

* SC(LR,LM)  CONTAINS  COMPLEX  SPECTRAL  COEFFICIENTS. 

* THIS  SUBROUTINE  prints  npr  COEFF  FROM  each  of  The  first 

* MPR  ROWS  OF  SC. 

COMPLEX  SC(LR#LM> 

nlim»npr 

IF(NLIM.GT.LR)  NLIMsLR 
HLIH«MPR 

IFCMLIH.GT.LM)  HLIMaLM 

WR I TE (6 » 60 1 0 ) LR.LM.NLIM.MLIM 

CO  30  M«1#MLIM 
MSaH-i 

WRITE (6*6020)  MS 

WRITE (6^6030)  ( SC(K#M)»N«l,NLIM) 

30  CONTINUE 

RETURN 

6010  FORMAT ( 1 H 1 / 1RH  COMPLEX  ARR AT , 2 1 U , «X , 5HPRI NT , 2 IU/ ) 

6020  FORM  AT (3H  Mr, 12) 

6030  FORMAT  ( (1H  ,<l  (<IX,  1PE13.6,  IH,,  IPE13.6) ) ) 

ENO 


I - 
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SUBROUTINE  PCPADJCPRECIP#STb«0W,ILG1  ,ESG,TG#OMEGAG»PRESSG#ILf'» 

1 TmEAnh,SH,STAWS,ILEV,lEVS,LTBS,NUPS,N3UPS,K0UNT,DEl) 

* CALCULATION  of  POTH  small  and  large  scale  PRECIPITATION, 

* CALCULATION  OF  CONVECTIVE  HEAT  AND  MOISTURE  FLUXES 

* THROUGH  A CONVECTIVE  ADJUSTMENT  PROCEDURE* 

* CALCULATION*  EVENTUALLY,  OF  PRECIPITATION  EVAPORATION 

* FOR  ILONG  POINTS  ABOUT  ONE  GAUSSIAN  LATITUDE  CIRCLE, 

PARAMETER  SILVsl5*SLEV30*SLValO*SILTs52*3ILGs6<l*SlLTH>26,3IRaao 
DIMENSION  PRECIP(l),STBROW(l) 

DIMENSION  ESG(ILM, 1),TG(ILM, 1 ),OmeGAG(ILM,1),PReSSG(1) 

DIMENSION  TMEANH(n,SH(l),STAWS(l  J,DEL(1) 

DIMENSION  VERTT(*ILV),VeRTO(IILV) ,PMB(SILV) 

ILONGsILG1-1 
ILEVMsILEV-1 
ILEVPalLEV* l 

DO  600  IKst, ILONG 


* vertt 

* VERTO 

* PMB 


vertical  column 

VERTICAL  COLUMN 

vertical  column 


OF  TEMP  AT  EVEN 
OF  SPHM  AT  EVEN 
OF  PRESSURE (MB ) 


LEVELS. 

LEVELS 

AT  EVEN  LEVELS 


DO  12  IHs1*LTBS 

12  VERTO(IH)=l.E-fl 
DO  13  Ih=i,ILEV 

13  VERTT(IH)=TG(IK,IH)4TMEANH(IH) 

DO  10  IHsi.ILFV 

IP  PMB(IH)=SH(IH)*PRESSG(IK)/100. 

DO  17  IH=1,LEVS 

TD= VERTT (IH+LT8S)-ESG( IK, IH) 

17  VERT Q(lH4LTBS)aSPCHLM(TD, PMB (IH+LTBS)) 
LPEP*ILEV/2tl 
wsOMEGAGCIK,LREP) 

PRESGbPRESSG(IK) 

NSUPXsNSUPS 
C*LL  CONADJ 

1 

IF(KOUNT.EQ 
IF(KOUNT.EO 
IF (K  BUNT ,GT 
IF (K  OUNT ,EQ 
IF (KQUNT ,GT 

* RESTORE  C 

DO  <10  I H * 1 , 


( VERTT, VERTQ, PCP,PRESG,W, PMB, ST AWS,NUPS,NSUPS, 
ILE VP , CEL ) 

.0)  PPECIP(IK)bO, 

.1)  PRECIP(IK)«PCP 

.1)  PRECIP(IK)bPRECIP(IK)4PCP*.5 

.0)  STBRCW(IK)»FLOAT(NSUPS-NSUPX) 

.0)  STBR0W(IK)aSTeROW(lK)4FL0AT(NSUPS-NSUPX) 

ORRECTED  VERTICAL  COLUMNS  OF  temp  and  es. 

ILE  V 


I 


40  TG(IK,IH)  ■ VERTT(IH)-TMEANHdH) 

42  E3G( IK» XHJ«VERTT(IH4l.TBS)»DEWPNT(VERT0CIH+LTB9)f PMBCXH+LTB8) ) 


SUBROUTINE  PERM  (WORK A, WORKS,  AA,BB,KP6#*3) 


* CALCULATES  SETUP  PIELO  FOR  3 TIMES  POWER  OF  2 TRANSFORM 
COMPLEX  WORKA(l),WORKB(l),AA,BB 


PI  « 3.19159265358979 
FACT  s 2,*PI/3, 

AA  s CMPLX(COS(FACT)»SIN(FACT)) 

BB  s CONJC(AA) 

FT  2 FACT/FLOAT (K3) 

00  125  K«  1 » KP6 
FK  s FT*FL0AT(K-1) 

WORKA(K)  s CMPLX(COS(FK),SIN(FK)} 
125  WORKB(K)  • CONJG (MORKA (K) ) 

retlrn 

END 
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SUBROUTINE  PHSCON(SEACON'RK,CEEACH'RKl'BETA'S/DEl'IlEV) 

* CALCULATES  CONSTANTS  FOR  SPECTRAL  MODEL  PHYSICAL  EFFECTS. 
DIMENSION  RKCn#8Cl)»OEL(n 

COMM  ON/P ARAMS/WH.TM, A, ASO»GRAV,RGAS,RCOCP,ROOA80,CPRES 

* CONSTANTS  FOR  SEA  SURFACE  FLUX 

SEACON  s GRAV*CEEACI-*BETA*A/(RGAS*DEL(ILEV)) 

* CONSTANTS  FOR  EDDY  VERTICAL  MOMENTUM  FLUX  CALCULATIONS 

ILEVM  a ILEV-1 
TZIP  a 273. 

DO  20  IHS l # ILE VM 

ST  = (S(IH)+S(IH*1))*,5 

RK(IH)  a (RKL/DEL(IH))*(GRAV*ST/(RGAS*TZIP))**2 
20  CONTINUE 

RETURN 

ENO 


SUBROUTINE  pout (P,C,T, PHI, PRESS, phi S,ES,LA,LRS,LRA,LM,ILEV,LEVS, 

1 PEE.PS,PEEMN,P$MN,TMEAN,TMeANH,RGAS#IPR,LC#KSYM, 

2 GLL, ILC1 ,ILATH,COA,KHEM,ALP,EPSI,LALP,wRKS,WRKL) 

* CONTROLS  PRINTED  OUTPUT  FOR  SPECTRAL  MULTILEVEL  MODEL. 

* each  variable  IS  passed  TO  SLBR  POUTF  FOR  output. 

* LC  CONTAINS  THE  CONTROL  PARAMETERS  for  output. 

complex  P UA»  l),e  (LA  #l),T(LA»n,PHl  (LA#  IMPRESS  (U.PHISU) 
complex  ES(LA#l),PEE(LAf i),PS(l) 

DIMENSION  GLL(l),ALP(l),EPSin),WRKL(l) 

DIMENSION  PEEMN(l),TMEAN(n,TMEANH(l) 

DIMENSION  WRKS(n,COA(l) 

DIMENSION  LC(3/ILEV/1) 
complex  TOZZ 

common/ times/  DEET,K CUNT, KSTaRT,KTOTAL#IFD IFF 


* ALWAYS  OUTPUT  INITIAL  ANO  FINAL  TIMES.  OTHERWISE  EVERY  IPR  TIMES 

IF(KOUNT.EQ.KSTART.OR.KOUNT.En.KTOTAL)  GO  TO  e2 
IFCIPR.EQ.O)  RETURN 

IF (MOD ( (KOUNT-KSTART), IPRj.NE.O)  RETURN 
82  kT=i 

IF(KOUNT.GT.KSTART)  KT«2*(K1UNT-KSTaRT)/(KT0TAL-KSTART) 

* VORTICITY,  levels  1 TO  ILE V, 

DO  100  L*1#ILEV 
K0slC(KT#L#1) 

IF(KO.GT.O)  CALL  POLTF (1,K0,KT,K0UNT,  °(1,L),LRA,LM,L,-KSYM, 

1 GLL.ILS1, ILATH,C0A,KHEM,ALP,EPSI,LAIP,WRKS,MRKL) 

100  CONTINUE 

* divergence,  levels  1 TO  ILEV. 

do  200  L=1 . ILEV 
KO=LC (KT.L/2) 

IF(KO.GT.O)  CALL  POLTF ( 2 , K 0 , KT , KOUNT  , C ( 1 , U , LRS , LM , L . KSYM, 

1 GLL, ILG1, IL A TH, CO A, KHEM.ALP.EPS I, L ALP, KRKS,wRKL) 

200  CONTINUE 

» TEMPERATURE,  LEVELS  1 TO  ILEV. 

* NOTE  - T CONTAINS  ThE  DEVIATION  ONLY#  SO  MUST  ADD  TMEANH(L). 

CO  300  LMiILEV 
KO*LC (KT , L # 3 ) 

TOZZ*T ( 1 , L ) 

Ta,L)*T(l,L)tTMtANM(L)*SQRT(2.0) 


I 
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IF  CKO.GT.O)  CALL  POLTF (3#K0,KT,K0UNT#  T ( 1 #L> »LRS,LH ,L*  K3YP, 
l GLL*ZLG1#ILATH/C0A,KHEM»ALP»EPSI,LALP»HRK8,HRKL) 

T(t,L)*TDZZ 
300  CONTINUE 

* GEOPOTENTIALS,  LEVELS  t TO  ILEV. 

* FIRST  CONVERT  PEE  TO  GZ  AT  ALL  LEVELS, 

CALL  GZFBP  (PHI ,P£E ,PS, T*E *N ,PEEMN,PSMN,LA,LRS ,L*, ILE V,RGAS ) 

DO  «00  L*1 # ILEV 

K0sLC(KT,L»O) 

IF(KO.GT.O)  CALL  POlTF(«,Kfl,KT,KOUNT,PHI(t,L)#LRS,LM,L#  KSYP, 
1 GLL,ILG1#ILATH,C0A,KHEM#ALP#EP5I#LALP#WRK3,WRKL) 

400  CONTINUE 

* SURFACE  PRESSURE, 

K0sLC(KT,l#5) 

IF(KO.GT.O)  call  PPUTF(5#K0,KT,K0UNT, PRESS, LRS#Lm#1#  ksym, 

1 GLL#ILG1,ILATH,C0A,KHEH,ALP#EPSI,LALP,WRKS#wRKI) 

* FOUNTAIN  FIELD. 

K0*LC(KT,l,6) 

IF(KO.GT.O)  CALL  POL TF (A , KO, KT, KOUNT,  PHlS,LRS,LH, J , KSYM, 

1 GLL, ILGt.lLATH,COA,KHEM,ALP,EPSI,LALP,NBkS,HRKl) 

* DEW  POINT  DEPRESSION,  LEVS  LEVELS  ENDING  AT  ILEV. 

IF(LEVS.EQ.O)  RETURN 
DO  700  N*1,LEVS 
L«ILEV-LEVS*N 
KOsLC (KT,N,7) 

IF(KO.GT.O)  CALL  POLTF (7 , KO , KT , KOUNT , ES ( 1 , N ) , LRS ,LM , L , KSYM, 
1 GLL,ILG1,ILATH,C0A,KHEM,ALP,EPSI,LALP,NRKS,NRKL) 

700  CONTINUE 

RETURN 

END 
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SUBROUTINE  POUTF (N V , KO , KT, KOUNT , SC t LM, L » KS^ , 

l gll#ilgi#ilath,coa,khem,alp#epsi,lalp#wrks,wrkl) 

* PRINTS  SPECTRAL  COEFF , MAPS  GAUSSIAN  GRID  GLL ( ILG  1 , NL AT ) , 

* PR  MAPS  POLAR  STEREOGRAPHIC  GRID  GLL  C N I ,NJ) 

* FOR  COMPLEX  COEFFICIENTS  IN  SC(LR#LM). 

* GLL  IS  AN  LCM  WORK  FIELD  FOR  MAPS  <NI*NJ  OR  ILG1*NLAT) , 

* COA(ILATH)  CONTAINS  THE  COSINES  OF  THE  COLATITUDE  (N  TO  S). 

* ALP(LALP,LM)  IS  A WORK  FIELD  FOR  LEGENDRE  POLYNOMIALS. 

* EPSI  IS  A FIELD  OF  CONSTANTS  THE  SAME  SIZE  AS  ALP. 

COMPLEX  seen 

DIMENSION  GLL(l) # alp (1). EPSI (l),WRKLCn 
DIMENSION  WRKS  ( i).COA(l) 

COMM  ON/PC OM1/  LRPR*LMPR,KGGM(5,3) ,KPSM(5»3) ,D60,DGRW*NHEM 
COMH0N/PCOM2/  L*R(10),C$(2»10) 

CINTaCS(l.NV) 

SC AL»CS (2#  NV ) 

* IF  THE  «-BIT  OF  KO  IS  1,  PRINT  THE  SPECTRAL  COEFFICIENTS. 

* LRPR  COEFF  ARE  PRINTED  FROM  THE  FIRST  LMPR  ROWS  OF  SC. 

IF (KO.LT.4)  GO  TO  2<l 

CALL  PC0F2(SC#LR»LM»LRPR#LMPR) 

WPlTE(6,6010)  L*B(NV),L»KOUNT 

* IF  THE  2-BIT  OF  KO  IS  1,  PREPARE  THE  GAUSSIAN  GRIP, 

* IF  KHEMan  THE  MODEL  IS  GLOBAL  AND  GGa ( ILG I , IL aTh*2)  , 

* OTHERWISE  THE  MODEL  is  HEMISPHERIC  and  GG«(ILG1,ILaTH). 

* THE  WINDOW  MAPPED  IS  IL  BY  MM  WITH  LOWER  LEFT  CORNER  (IW,Jk). 

2<l  IF(MODtKO#«).LE.l)  GO  TO  H 
NLATsILATH 

IF(KHEM.EQ.O)  NLATaILATH*2 

CALL  SPAGG2(GLL,ILG1,ILATm,cOA,KHEM,SC,LP.LM,KSm, 

i alp»epsi,lalp»npks,wrkd 

IWaKGGM ( I »KT) 

JWbKGGm (2#KT) 

LL«KGGM(3»KT) 

MMaKGGM(a,KT) 

CALL  FC0NW2(GLL,CINT,SCAL,ILGl,NLAT#IW#JW#tL#MM#KGGMf5#KT)) 

WRITE (6.6010)  LAR(NV),L,KOUNT 

* IF  THE  i-BIT  OF  KO  IS  1.  PREPARE  THE  POLAR  STfReOGBaPmIC  CRIP. 

* THE  GRID  IS  (NI.NJ)  WITH  POLE  AT  UP.JP).  GRIP  S 1 2F  C6«  M. 

* AT  60  DEG,  AND  GREFNWICM  IS  ORIENTED  AT  DGRW  DEGREES. 

* NMEMal  COMPUTES  THE  N HEM,  NHEMag  THE  S HEM, 


20  IF(M0D(K0,2).NE.l)  RETURN 


NI»KPSM(1,KT) 

N JsKPSH (2*  K T) 

IP»KPSM(3,KT) 

jP«KPSM(a,KT) 

CALL  SPAPS2(GLL,NIfNJ,IP,JP,060,OGRW,NHEM,SC,LR,LM,KSM, 
1 ALP#EP9I»LALP#HRK3,WRKL) 

CALL  FC0NW2(GLL,CINT,3CAL,NI,NJ,1, l ,NI,NJ,KPSN(5,KT) ) 
*RITE(6,6010)  LAP(KV),L,KOUNT 

RETURN 

fcOlO  F0RHAT(1H0»A<J,7H  LEVEL  ,I2,10H  AT  STEP  #I<0 
END 
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SUBROUTINE  PTS6CNF1 ,NF2,GZ,T,U, V , ES , GZS , SP , GLL # LG , 
i LV,PR,SK,SIG,ILG,ILAT,KHEM,WET,KCR,KWT,KCV) 

* INTERPOLATES  NK  SIG^A  LEVELS  FROM  lv  pressure  levels 

* OF  GAUSSIAN  GRIDS  CILG1#NLAT), 

* IF  KHEM«o  The  MOCEL  IS  GLOBAL  and  NLATsILAT, 

* IF  KHEM=1,2  THE  HODEL  IS  HEMISPHERIC  AND  NLATalLAT/2 

* LEVELS  ARE  NUMBERED  FROM  THE  TOP  DOWN  CaS  IN  ARRAY  PR). 

* maximum  number  OF  LFVELS  - PRESSURE=lSf  SIGMA3I5. 

* input  is  on  sequential  file  nfi  in  the  following  order.... 

* GZS,GZ(LV)fT  (I.V),  (li:,V>  (LV))#E3(LV)#  CDR#HT»CV) 

* output  is  on  sequential  file  nf2  in  the  following  order.... 

* GZS,LNSP,GZ(NK), ( (U,V) (NK) ),ES(NK), (DP,WT,CV) 

* COPE  MAY  be  shared  BY  (GZ,U»ES) , (T,V) . 

* GLL  IS  A WORK  FIELD  OF  LA  WORDS  IN  LCM. 

PARAMETER  SILVsi5#ILEV=0, JLVsiO, JlLTa52,SILG»6R,SILTH«26, JIR*20 

parameter  silpj=silv+i 

DIMENSION  GZCLG#l)»T(LGil)»U(LG#l),V(LG,l)#ESCLG#l) 

DIMENSION  GZS(1),SP(1)#GLL(1 ) 

LOGICAL  HET,KDR,KWT,KCV 
DIMENSION  PR(1),SIG(1) 

* SCM  WORK  ARRAYS. 

DIMENSION  ZL(SILV),TLCJILV),ULC*ILV),VL($ILV),Sl($ILV),TULCSILV), 
*TVLCJILV),TSI(SILV),SG(JILV),SLLC$ILV),SVL(SILV),SSL(JILV), 
*SGE(SILV),SGZL(JILV),S(SILP1)#MRKS(130) 

» rtTPUT  Packing  CONTROLS. 

C0MH3N/PKC0M/  npgzs,npsp,npgz,npw,npes,npwt,nfcv,nppp 

LOGICAL  OK 

DATA  GRAV,RGAS/  9. *11616,  207.  / 

* SET  CONSTANTS. 

IDsO 

ACC=.1*GRAV 
PGASIN*1 ,/RGAS 
NLATsILAT/2 

IF (KHEM.EQ.O)  NLATsILAT 
ILGlelLGM 
L A s I LG  1 *NL  4 T 
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* CONVERT  PR  TO  LOG (PRESSURE) . 

HO  2 L«l»lV 
2 PR  CL  ) 2 *L0G(PR(D) 

DLnP  = PR(LV)-PRCLV-l) 

* SET  SG  TO  LOGCSIGPA). 

DO  a Ksl,NK 

U SG (K ) s ALOG(SIGCK)) 

* AVERAGE  SG  TO  EVEN  LEVELS  IN  SGE. 

NKMl  = NK-1 

DO  5 K*l,NKMj 

5 SGECK)=  .5  * (SGCK)+Sr,(K*n) 

SGE(NK)=.5*SG(NKI 

CO  fc  Lsl.LVl 

6 S(L)  = t./(PRCl  + n-PR(L)) 

* READ  MOUNTAIN  FIELD  (M/SEC)*«2. 

* READ  GEOPOTENTIALS  (M/SEC ) **2  AND  TEMPERATURES  (DEG  K). 

* GZ  AND  T may  GE  IN  any  ORDER  IN  NF1, 

CALL  RSGGP(GZS,ILG1,NLAT,NF1, in.an  GZS , 1 , OK , GLL , WPKS ) 

REWIND  nfi 

DO  £io  Ls 1 » L V 

210  CALL  RSGGP(GZ(1 ,L), ILGl,NLAT,NFi,ID,aH  G Z , L , OK  , GLL  , R RK S ) 

REWIND  NFI 
DO  220  L=1.LV 

220  CALL  RSGGPC  Tn,L),ILGl,NLAT,NFl#ID,«H  T , L , OK  , GLL  , WRY  S ) 

* calculate  surfacf  pressure  and  interpolate  heights  TO  sigma  SFC. 

DO  270  1 = 1 , LA 

0 0 245  L = 1 # L V 
ZL (L ) =GZ ( I > L ) 

TLCL)=-RGAS*T(I,L) 

2 US  CONTINUE 

GZSIsGZSCI) 

GUESS=  PRCLV)  - GZSI/CRGAS«250.) 

CALL  TF.RPl  (Gu£sS,GZSI,ZL,TL,PR,  ACC,LV) 

SP(I )=GUESS 

CO  250  K=1,NK 


I 
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XLNP=SP(I)*SG(K) 
fiUAPSEa(TL(LV)-TL(LV-i))/  Di.NP 

CALL  TERPa(SGZL(K)fDU^MY,XLNP,ZL,TL,PR#LV,RLAP9E) 

250  CONTINUE 

00  255  K=  1 , NK 
255  GZ(I,K)=SGZL(K) 

270  CONTINUE 

* OUTPUT  SURFACE  GEOPOTENTIAL  (m/SEC)**2. 

* OUTPUT  LOG  SURFACE  PRESSURE  (MILLIBARS). 

* OUTPUT  GEOPOTENTIALS  (M/SEC)**2. 

CALL  WSGGPCGZS,ILGi»NLAT#NF2,ID,«H  GZS, 1,NPGZ3,GLL#WRKS) 

CAll  WSGGp ( SP,IlG1»NLaT*nF2»ID,0HlnSP.1»NPSP»GlL#WRK5) 

00  280  K=1,NK 

280  CALL  wSGGP(GZ(l ,K),ILG1,NLAT,NF2,ID,4H  GZ,K,NPgZ,GLL,WRKS) 

* READ  WINDS  (U#V)«(U»V)*COS(LAT)/(EARTH  RADIUS) 

DO  310  L=1,LV 

CALL  RSGGP ( U(l,L),ILGlfNLAT#NF|fID,«H  U,L,OK,GLL,WRKS) 

CALL  RSGGP ( V(l,L),ILGl,NLAT,NFl,ID,«H  V,L,OK,GLL,NRKS) 

310  CONTINUE 

* COMPUTE  VERTICAL  DERIVATIVE  AND  INTERPOLATE  ONE  COL  AT  A TIME. 

DO  371  1=1, LA 

DO  3<j6  L=  1 , L V 
UL (L ) =U ( I , L ) 

VL(L)=V(I,L) 

346  CONTINUE 

CALL  DFDS(TUL,UL»S,LV,l.,l.) 

TUL(1D30. 

CALL  DFDSCTVL,vL,S,LV,1.,1.) 

TVL ( l ) = 0 , 

DO  351  K s 1 , N K 
XLNP=SPCI)+SG(K) 

RLAPSE=(TUL(LV)-TULCLV-1))/  olnp 

CALL  TERP2(SUL(K),DUMmY,XLNP,UL,TUL,PR,LV,RLAPSE) 

RLAPSE=(TVL(LV)-TVLCLV-D)  / DLNP 

CALL  TERP2(SVL(K),0UMMY,XLNP,VL,TVL,PR,LV,RLAPSE) 

351  CONTINUE 

DO  356  K*l#NK 
U(I,K)=SUL<K) 

V(I,K)=SVL(K) 
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356  CONTINUE 


371  CONTINUE 

* OUTPUT  WINDS  ON  FILE  f'F2. 

CO  381  Ksl,NK 

CALL  WSGGP(  U(l,K),ILGIfNLAT#NF2,lD,4H  U»K,NPw  ,GlL»WRK3) 

CALL  WSGGP(  V(1#K),1LG1,NLAT,NF2, ID,«H  V,K,NPw  ,GLL,WRKS) 

381  CONTINUE 

* READ  DEW  point  DEPRESSION  (DEG  C)  FROM  FILE  Nfl. 

IF(.NOT.WET)  GO  TO  510 
DO  <110  LMiLV 

CALL  RSGGP(ES(1,L),ILG1,NLAT,NF1,ID,«H  ES,L,OK,GLL,wRKS) 

410  CONTINUE 

* COMPUTE  VERTICAL  DERIVATIVE  AND  INTERPOLATE  ONE  COL  AT  A WE. 

DO  472  I«1»LA 

DO  447  LS1 »LV 
447  SLCL)*ESCI,L)*RGAS 

call  DFDS(TSL,SL,S,LV,1.,1.) 

TSLUJaO. 

DO  452  K*1,NK 
XLNP3SP(I)+SGE(K) 

RLAPSE=(TSL(LV)-TSLCLV-1))  / DLNP 

call  TERP2(SSL(K) ,0LMWV,VLNP,SL,TSL,PR|LV,RLAPSE) 

452  CONTINUE 

DO  457  K=1,NK 
457  ES(I#K)*SSL(K)*RGASlN 

472  CONTINUE 

* OUTPUT  DEW  POINT  DEPRESSIONS  ON  FILE  NF2  • 

CO  482  K=1,NK 

482  CALL  WSGGP(E$(l,K),ILGl,NLAT,NF2,ID,4H  ES ,k ,NPeS ,GLL , WRKS ) 

* TRANSFER  GAUSSIAN  GRID  PHYSICS  FROM  NFl  TO  NF2. 

510  IF ( .NOT  ,KQR ) GO  Tfl  520 

CALL  RSGGP(SP,ILG1,NLAT,NF1, ID,4H  DR,1,  OK  ,GLL,WRKS) 

CALL  WSGGP(SP,ILG1,NLAT,NF?,ID,4H  D« , 1 ,NPOR  ,GLL #WRKS ) 

520  IF(.NOT.KWT)  GO  TO  530 
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call  RSGCP(SP,ILCt,KLAT,NPl,ir,«H  WT,l,  OK  ,GLL,w9K3) 
CALL  *SGGP(SP,ILG1,M»T,NF2,ID,4H  WT,  1 ,NPWT,GLL»wRK3) 


r 


530  IF(.NOT.KCV)  GO  TO  999 

CALL  PSGGP(SP,lLGl,NLAT#NFl,IO,aH  CV,I,  OK  ,GLL»H«K5) 
CALL  KSGGP(SP,ILGl,NLAT,NF2,I0,9H  CV, 1 ,NPCV,GLL#W*K3) 

999  RCTLPN 
END 
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SUBROUTINE  QD AW2 (u, V, P,C, EPS  1, PROW, CROW, 

1 LRU,LRV,LRA,URS,LALP,LM,KHEM, IR) 

* spectral  calculation  of  wind  components  U(LRU,LM),  V(LRV,LH) 

* FROM  RELATIVE  VORTICITY  P(LRA,LM)  and  DIVERGENCE  CCLRS,LM). 

* IF  MODEL  IS  HEMISPHERIC,  U,C  ARE  SYMMETRIC, 

* V,P  ARE  ANTISYMMETRIC. 

* PROW, CROW  are  work  ARRAYS  FOR  ONE  UNSQUEEZED  ROW  OF  P,C. 

* THEY  MUST  HAVE  A LENGTH  OF  IR  + 2 COMPLEX  WORDS. 

COMPLEX  UCLPU, 1),V(LRV, J ),P(LRa,1),C(LRS,1) 

DIMENSION  EPS  I (LALp , 1 ) 

COMPLEX  PROW ( 1 ) »CROW ( 1 ) 

LOGICAL  HEMI 

COMPLEX  PR, CR, PL, CL,  IZ 

, 

HEMI*. FALSE. 

IFCKHEM.NE.O)  HEMIs.TRUE. 

IRP2=IR+2 

IZs(o.,t.) 

CO  12  Ksl,IRP2 
PR0W(K)s(0.,0.J 
12  CR0W(K)a(0.,0.) 

DO  40  Ms  1 , LM 

ms=m«i 

FMsaFLOAT(MS) 

* PL T UNSQUEEZED  ROW  OF  P,C  IN  PROW, CROW. 

DO  14  Ns  1 , LR A 
KsN 

IF (HEMI ) K c f J ♦ N 

PROw(K)sP(N,M) 

14  CONTINUE 

DO  16  Ns  1 , LRS 
KsN 

IF  (HEMI ) KsNtN-1 
CROW (K)sC (N,M) 

16  CONTINUE 

* COMPUTE  ONE  ROW  OF  l. 

* n indexes  the  (possibly)  squeezed  Row  op  u. 

* K INDEXES  The  UNSGUEEzED  ROWS  of  P,C,EPSI. 


CO  20  N si, LRU 
nS=h+n-2 

IF (HEMI ) NSsNS4(N-l) 


I - 101 


IF  (NS.EQ.05  G9  TB  20 
PNS=Fl8AT(NS) 

CBNsFMS/(FNS*CFNS*1.)) 

H=N 

IF(HEMI)  KsN+N-1 

IFCK.LT.IRP2)  EPSR»EPSI(K  + 1,M)/CFNS+1.) 

EPS  sEPSI(K#M)/PNS 
PRs(O.,0.) 

IFCK.LT.IRP2)  PRsPPCW(K*|) 

PLs(0.,0.) 

IF(K.GT.l)  PLsPRB^(K-I) 

U(N,M)=  - EPS*PL  ♦ EPS«*PR  - IZ*CRPWCK)*CON 
20  continue 


* COMPUTE  PNE  RP*  pF  V. 

* N INCEXES  The  (PPS5IPLy)  sgujffzed  RO*  OF  V, 

* K INDEXES  The  L'NSGL'EFZEF  R'WS  "F  P,C,EPSI. 

DP  jo  N=1,LRV 
NGsH+n-2 

IF(hemI)  N$=NS+N 
IF  (NS.EG.O)  GP  TP  3 C 
FNSsFLPAT (NS) 

COKsFMS/  CFNS*CFNS*1  , ) ) 

K -N 

I F ( HEM  I ) K s N ♦ \ 

IFCK.LT.IRP2)  F°SRsEPSI  (K+l.H)/ (ENS+1 .) 

EPS  =EPSI  (K.vj/fks 
C«=CO.,0.) 

IFCK.LT.IPP2)  CPsCBP^CK+l) 

CLsCO.,0.) 

IF(K.GT.I)  CL=CF*fcfK-l) 

VCN,M)=  ♦ EpS*CL  - EPSP*CP  - IZ*PRPI»CK)*C8N 
10  CONTINUE 
40  CONTINUE 

* SET  THE  mean  VALUES  PF  U AND  V. 

IF(HEMI)  UCM):  P C 1 # 1 )*EPSI  C2»  1 ) 
IFC.NPT.HEMI)  U(l,l)»  PC2#1)*E:PSIC2,1) 
IFc.nbt.hemI)  V(l,i)s.C(2,l)*EPSlC2,l) 

RETLRN 

END 
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SUBROUTINE  RhSSI  (PEFBaR,PEET,SCS,LA,LRS,LM#ILEV,SF#DT) 

PARAMETER  IM  = 5,  SIR  ■ 25#  IRM  * 2*SIR*1 

« This  ROUTINE  is  REGUIRED  TO  implement  the  SEMI-IMPLICIT  TIHE-STFP 
» METHOD. REFERENCE  SHOULD  BE  MADE  TO  THE  NOTES. 

* IF  MODEL  IS  HEMISPHERIC,  D I , pEET , SDS  ARE  SYMMETRIC. 

* EACH  LEVEL  IS  DIMENSIONED  (LRS.LM). 

* EACH  LEVEL  IS  SEPARATED  BY  LA  COMPLEX  WORDS. 

* MAXIMUM  VALUE  "F  ILE V IS  15, 

COMPLEX  PEEOAR(LA,n#PEET(LA»l)#SDS(LA#l)#TEMP(IM) 

COMPLEX  SUM 

DIMENSION  SF(1) 

REAL  mi#mh,miimi  tf\  ,''2,mp,HPmi,m,ho,mPI,m2mj 

COMMON  / NEWmat  / MI(IM,IM),miI(im,IM),MIIHJ(IM,IM),M1(IM,IH), 

* m2(IM,Im),mP(Ih,im},mPmi(im,im),M(IM,IM), 

* mH(IM,Im),mpI(im,IM,IRM),M2H1(IM,IM) 

ilevm=ilev-i 

LMSC=LRS*LM 

n 1 ILl  = 1,  IRS 
CM  1 IL2  = 1#  LM 
IL  = ( I L 2 — 1 )*LRa  ♦ ILl 
IP  s ILl  ♦ IL2  - i 
DO  2 I H s l,  ILE V 
TEMP(IM)  = 0.0 
DO  2 JH  = 1,  IL  E v 

2 TEMP  ( in ) = TEHP(IH)  ♦ SDS(IL# JM)*M(JH,IH) 
rM  I"  ! 1#  ILEV 

3 TEMP  ( I m ) = PEET(IL,IH)  ♦ DT*TEMP(IH) 

DO  5 IM  = 1,  ILEV 

SUM  = o.O 

DO  0 JH  s 1,  ILEV 

a SUM  S SUM  ♦ TEMP(JH)*mPI(JH,IH,IP) 

5 PEEpAR(IL,IH)  s SUM 
1 CONTINUE 

RF  TURN 
END 


PROGRAM  BPTS6 

* CONTROL  PROGRAM  FOR  PTS6 , 

* INTERPOLATES  NK  SIG^A  levels  from  LV  PRESSURE  LEVELS. 

PARAMETER  IILV*15,SLEV«0»iLVsl0, HLT=52,SILGs6«,SILTH«26,SIRt£0 
PARAMETER  SL*W  a (SILGM  )*SILT 

COmmon//GZ(SLAW,SILV),T(SLAW,SILV) ,GZS(SLAW),SP($LAW),GLLCSLAW) 
(DIMENSION  U(1)#V(1),ES(1) 

EQUIVALENCE  CU,ES,GZ), (V,T) 

* SPECTRAL  model  CONTROL  PARAMETERS. 

LOGICAL  MTN,WET,KpR,KWT,KCV,KDIV 
COMMON/PSCOM/LV,PR(1LV),NK,SIG(SlLV) 

COmmon/DTCOm/  iCATlMCia) 

* OLTPUT  PACKING  CONTROLS. 

common/pkcom/  npgzs,npsp,npgz,npw,npes,npwt,npcv,npdr 

CAT  A NFl , NF2,NPGZ3,NpSP,NpGZ,NPW,NPES,NPWT#NPCV,NPDR 
1 / «2,  52,  1,  1,  1,  1,  1,  1,  1,  l / 

* READ  CONTROL  LA'nEL  FROM  file  NFl  AND  COPT  TO  FILE  NF2, 

CALL  INDUMP 

CALL  3PLARCNF1, 1 ,LV,PR,NK,SIG,LEVS,ILG.ILAT,KHEm,IR,OEET, 

1 mTN,WET,kCP,kKT,kCV,KCIV,KSTAHT,KTOTAl,IPRG,  IPCP,IDATIM) 

IF (LV.EG.O)  STOP 

CALL  SPLAP(flF2t2,LV,PF,NK,SlG,LEVS,ILG,ILAT,KHE,MR,nEET, 

1 mtn,wet,kdr,kkt,kcv,kdiv,kstart,ktotal,iprg,ipcp,ipatim) 

* PERFORM  The  vertical  INTERPOLATION. 

* LG  INDEXES  The  MULTILEVEL  arrays  INSIDE  PTS5, 

NLATslLAT/2 

if (KHEM.EQ.O)  NLAT*ILAT 
LGsNLAT*(ILGM) 

CALL  PTS6(NFl,NF2,GZ,T,U,V,ES,GZS,SP,GLL»LG, 

1 LV,PR,NK,SIG, ILG, ILAT.KHEM.WET  ,KCR,K0T,KCV) 

«RITE(6,6090)  (I0ATlM(I),Ia7, 13) 

STOP 

6090  FORMaT(1H0,7a4,6X,19h  ENT  SPECtRAL  RPTS6 ) 

END 
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SUBROUTINE  RSGGP  (GG  • NLG  , NL  A T , NF  , I D # N AME  , N , OK  , GGP/ WRKS  ) 

* READS  array  GG(NIG,HAT)  FROM  SEQUENTIAL  FILE  NF 

* PRECEDED  6 Y AN  IDENTIFYING  LABEL  OF  7 WORDS, 

* WRITTFN  BY  SUBROUTINE  WSGGP. 

* IC  a IDENTIFICATION  NuMPFR  FOR  THE  RECORD, 

* name  = ALPHANUMERIC  LABEL  FOR  THE  FIELD, 

* N = NUMERIC  lapel  FOR  the  FIELD. 

* OK  s ,T , OR  ,F.  ACCORDING  TO  WHETHER  FIELD  IS  FOUND  OR  NOT, 

* GGP,wrkS  ARE  work  FIELDS  USED  ONLY  IF  FIELD  IS  PACKED. 

* GGP  = NLAT*((NLG-1)/NPACK*2)  WORDS  JN  LCM, 

* WRKS  = NIG  W«HOS  IN  SfH. 

DIMENSION  GG  (1),  GGP  (U,  WRKS  (t) 

LOGICAL  OK 
DIMENSION  LA8C7J 
CATA  KFLD/  aHGRlO  / 

OKs. TRUE. 

IF(NF.LE.O)  return 

* READ  LABEL  OF  THE  NEXT  RECORD  ON  FILE  NF . 

15  READ(NF,ENOsl6)  LAP 
GO  TO  17 

« IF  LABEL  IS  NOT  FOUND  BEFORE  ENO-OF.FILE  IS  ENCOUNTERED 

* SET  OKs, FALSE.,  REMIND  THE  FILE,  AND  RETURN. 

16  oks. false, 
rewind  nF 

WRITE (6,610)  NF, ID,NAME,N,NLG,NLAT 
RETURN 

* IF  LAPEL  NOT  CORRECT  GO  BACK  AND  READ  THE  NEXT  RECORD . 

17  IF(KFLD.NE.LABCl))  GO  TO  15 
IF  C ID.NE.LAB(2n  GO  TO  15 
IF (NAME.NE.LABC3) ) GO  TO  15 
IF ( N.NE.LAB(U))  GO  TO  15 
I F ( NLG.NE.LABC5))  GO  TO  lc 
IF(NLAT.NE.LAB(6))  GO  TO  15 

* IF  LABEL  IS  CORRECT,  RACKSPaCE  TO  PREPARE  FOR  READING  THE  FIELD. 

* GET  THE  PACKING  DENSITY  FROM  The  LABEL. 

BACKSPACE  NF 
NPACKSLABC7) 

* if  there  is  no  picking  peac  gg  oirfctly  and  return. 
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IF(NPACK.GT.t)  GO  T 8 25 
LAsNlg*NL AT 

REAC(NF)  LAB,  {GG(I),I*1,LA) 

1*PITE(6,620J  I0,NAME,K,NLG,NLAT,NPACK,NF 
RETURN 

AN  ERROR  HAS  BFFN  ENCOUNTERED  IN  THE  LABEL  FIELD 

25  CALL  FPAK 
9R  RETURN 


6J0  FPRHAT  (JH  ,13H..EOF  Os  rILE,l3,18H  LOOKING  FOR  GRID , 16  , A<l , J 15  ) 
620  F ORHAT  C 1 H , I5,2X*  AU, 13, 6H  GR ID , 1 5 , 1 4 , 0H  NPACKs,I2, 

\ lbH  READ  FROM  FILE, 133 

END 


PROGRAM  RSPhfc 


* CONTROL  PROGRAM  for  MULTILEVEL  SPECTRAL  MODEL  - VERSION  6. 

PARAMETER  SILVsl5,JLEVso,SLVsir,$lLTs52,JILG=6«,$ILTHs26,$IRa20 

LOGICAL  MTN,wET,KrR,K^T,KeV,KDIV 
COMM  ON /SMC  CM/  MTN,"E.T,KDR*KMT,kCV,KCIV 
DIMENSION  PR($LV)#SIG(*ILV),IDATim(1«I) 

Common/ TIMES/  DEE T,KOLNT,KST ART, K TOTAL, IFDIFF 
COMM  ON/P ARAM2/  BETA,  AVEPT,PIVCM,FP,FC,PPEE,FPS,FS 
COMMON/PARA M 3/  D I FU S D , D I F USS , V I FUSS 

COMMON/PARAM4/  cff.ach,rkl 

COMMON/4DJPCP/MC,HF,H“,AA,nFpTM,LHEAT,MOHDJ,MOlFLX 
DIMENSION  LCn.SlLV#  10) 

COMM  ON/PC OMl/  lRPR»LMPR,kGG"(5,3),KPSM(5,3),D6  0,DGRW,nMEm 
C0MM0N/PC0*'2/  LAB(1C),CS(2,10) 

COMMON/MAPGG/  MGGDR,mGGwT,MGGCV 
COMMOn/PKOUT/  nPG2,NPSP,NRW,NPES 
COMMON/EGRAPH/  ET5TS(iei,6) 

* NF1  r INPUT  FILE,  NF2  s OUTPUT  FILE*  NFPCF  s PRECIP  OUTPUT. 
DATA  NF 1,NF2,NFPCP/  52,  72,  74  / 

* MODEL  PARAMETERS. 
data  IFPIFF/  1 / 

DATA  beta,  DIVCH,  AVERT,  fp,  FC,  FPEE,  FPS,  fs 

1 / 1.,  2 . 0 F • 5 , .25,  .05,  .05 , . 0 5 , , 0 j , . 0 5 / 

data  CEEACH,RKL/  1.2F-3,  20.  / 

DATA  DIFUSD,DIFUSS,VTFUSS/1 , E»5 , 1 , E + 5 , 0.0  / 

DATA  HC,hF ,HM/  1.0, 0.8, 0.8  / 

data  lhe*t , m 0 1 a r J ,mgiflx/  1,1,1/ 

* PRINTER  OUTPUT  CONTROLS. 

data  MGGDR,“GG*T,MGGCV/  0,  0,  0 / 
data  nvar,lt"T/  7,iei  / 

DATA  LRPR»LMPR  / 12,13  / 

CATA  IGE, IGM, IGO, IGC/  0,0,0, 1 / 

CATA  NPGZ,NPSP,NPW,NPES,NPPCP/  1,1, 1,1*1  / 

* read  CONTROL  LABFL  FROM  file  NFl  and  COPV  to  files  NF2,NFPCP. 


CALL 

CALL 

1 


INDUMP 


SPLAR(NF1, l.LV.PF, NK,SIG. LEVS, ILG.IL AT,KHEM, I R.DEE7, 
mTN,wet,kdR,K‘'T,NCV,KDIV,KSTART|KTOTAL,IPRG,IPCP,IDATIM) 


- loe 


I 


IF(IV.EC.O)  STOP 

IF(.NOT.WET)  LEVSsO 

IF  (WET, AND, LEVS, EG. C)  WE Ts. FALSE. 

CALL  SPLAB(NF2,2,LV,PR,NK,SlG,LEVS,ILG»I!-AT,KWEM,lR,nEET, 
l mtn,wet,kdr,kwt,kcv,kdiv,kstart,ktotal,iprg,ipcp,idatim) 

CALL  SPLAH(NFPCP,2,LV,PR,NK,SIG,LEVS, ilg,ilat,khem,ir,deet, 

1 MTN,WET#KDR,KWT,KCV,KDIVfKSTART,KTOTAL,lPPG, IPCP,inATIP) 

ILEV«NK 

* READ  MODEL  1/3  CONTROL  PARAMETERS, 

RE AC (5,5010)  IPR, IEPP,NHGR,NTEST 
CALL  INPOC(LC, ILFV.NVAR) 


* PERFORM  THE  FORECAST. 

CALL  SPW6(ILG,ILAT,KHEM,IR,ILEV,LEVS,SIG» 

1 NE l,Np2,NFPCP#LC»ETnTS#LT0T, IePR»NOGR#  IPR» 

2 MTEST#IPRG,IPCP,NPPCP,IDATIM) 

* DRAW  ENERGY  GRAPHS  IF  REQUESTED, 

IF (NOGR.FQ.O. OR.KOUNT.LT, NOGR)  GO  TO  RR 

call  egrapscetots,ltot,kount+i,ige, igm,igq,igo 

RR  HRITE(6,60RO)  ( ID AT IM ( I ) » I *7  » 13  ] 

STOP 

5010  F0RMATC6I3) 

6005  F0RN'AT(1H1//32H  p,E.  SPECTRAL  MCDEL  * VERSION  b) 

60R0  F0RHAT(lH(),7Aa,6X,lRh  END  SPECTRAL  RSPNfc) 

END 
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PROGRAM  PSTP6 


* CONTROL  PROGRAM  FOR  STPfc, 

« CONVERTS  NK  SIG"A  LEVELS  OF  GAUSSIAN  GRIDS  TO  LV  PRESSURE  LEVELS 

PARAMETER  SlLValS, SLEVsO»  SLVslO, !ILTs52,SILG36a, $ILTHs26#IIR««0 
parameter  slaw  s csilo  + i )*SILT 

CPMM|»N//GZ(SLAh,SILV)  ,T  (SLAU,  JILV) 

DIMENSION  U(1),V(l),ESn) 

EQUIVALENCE  (U,ES,GZ), (V,T) 

LOGICAL  MTN,WET,KDR,K^T,KCV,KDIV 
DIMENSION  PR(SLVI,SIG(SILV) , IDATIM(ia) 

DIMENSION  HPGZcSLV),MFT(SLV),HPnmLV)lHPKSP(*LVj,MPES(*LVJ 

DATA  NFj ,NF12,NF2/  72 , , fl2  / 

DATA  NPSP#NPGZ.NPT#NPt‘»NPES/  1,1, 1,1,1  / 

* READ  CONTROL  LAPEL  FROM  FILE  NFt  AND  COPY  TO  FILE  NF2 , 

CALL  INDUMP 

CALL  SPL*R(NFl,  l,LV,PR,NK,SIG,LEVS,ILG,ILAT,K(-Eu,IP,r,EET, 

1 MTN,«ET,KDR,Ki*T,KCV,KCIV,KSTAFT,KTOTAL,IPRG,IPCP,IDATIM) 

IFfLV.EQ.O)  STOP 

CALL  SPL AH (‘c2, 2, L V, PR, NK, S I G,LE VS, ILG,IL AT,  KhEM,  I R,  DEE T, 
l mtn,keT,kdR,kut,kcV,kdIV,k'START,kT0TAL,IPRG,IPCP,IDATIM) 

* IF  The  “OrEL  IS  HEMISPHERIC  (Ki-ems  1,2)  CALCULATIONS  ARE  DONE 

* F0R  Tm£  SOUTHERN  hEhiSPmERE  OnlT. 

nLATsIlat 

IF (KHEM.NE.01  NLATsILAT/2 

IGGsNlaT*(ILGM) 

* PEAD  OUTPUT  CONTROLS  FROM  CARDS  AND  PERFORM  INTERPOLATION. 

* repeat  until  nsteps  is  negative,  Then  stop, 

110  READ (5,5010)  NSTEPS,  mAPS,uPSP, I*,JW,LL,Hu 

IF (NSTEPS. L T . 0 5 *R I TE ( fa , 609 0 ) ( I D A T I M ( I ) , I s7 , 1 3 ) 

IF (NSTEPS. LT.O)  STOP 

* IF  M4PS=0,  *aP  CONTPOlS  ARE  not  read. 

IF (MAPS. EG.  0)  GO  TO  210 
REAC(5,5010)  (MPGZ(L),Lsl,LV) 

PEAC (5,5010)  ( MPT(L),Lsl,LV) 

REAC(5,5010)  ( MPW(L),Lal,LV) 

REAC(5,5010)(MPv»SP(L),Lal#LVl 
REAC  (5,5010)  (MPES(L),Lsl,m 
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210  CALL  STP6(NFl,NFl2,NFa,PR,LV,SIG,NK,GZ,T,U,VfES,LEVS,LGG, 

1 ILG#NLAT ,NSTePS/  MAPS, MPSP,MPGZ, MPT, mPw,MPWSP,MPES, 

2 I**#  Jh#LL,Hf,NPSP,NPGZ#NPT,NPwfKPE8) 


GO  TO  110 
5010  FORMAT ( 1513) 

6090  F0RMAT(lH0,7Aa,6X,  19H  END  SPECTRAL  RSTPfe) 

end 
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SUBROUTINE  SAVPCP(PCPPAK#ST0PAK, ILG1 • IIATh#KHEH,NPPC«# 

1 KOUNT,KSTART,IPCP,NFPCP,NPPCP,GLL#WRkS) 

* SPECTRAL  model  PRECIP  AND  STABILITY  count  SAVING  routine. 

* SAVES  GAUSSIAN  GRIOS  OF  PRECIPITATION  AND  STABILITY  COUNT 

* EVERY  IPCP  TIMESTEPS  IF  REQUESTED. 

* k s yh  s o model  is  global  and  complete  grid  is  saved. 

* kSYm  = 1 MOOEL  IS  HEMISPHERIC  AnD  one  HEM.  only  is  saved. 

DIMENSION  PCPPAK(l),STRPAK(l),GLL(lLGl,n 
DIMENSION  wRKSm 

* save  every  ipcp  testers  providing  ipcp.ne.o 

IF (IPCP.EQ.O)  RETURN 

IF (MOD( (KOUNT-KSTART),IPCP3 .NE.O)  RETURN 

* SET  CONSTANTS 
NLAT=ILATH 

IF  (KHEM.EQ.O)  NLATsILATH*2 
IDsKOUNT 

* WRITE  THE  GRID  OS  FILE  NF  WITH  RACKING  NPPCP. 

CALL  WSGGP(PCPPAK#ILG1,HLAT#NFPCP,ID#«H  FCP, t , NPPcp, GLL.WRkS) 
call  WSGGPfSTBPAK, ILG1,NLaT,NFPCp, IO.ttH  STB , 1 , NPPcP , GLL , wRK S ) 

RETURN 

END 
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SUBROUTINE  SA VPRG(NF2,PHI ,U, V,E$,PHIS,PS,PEE,TMEAN,PEEMN,PSMN, 

1 RGAS.L* ,l4h,lps,lra,lpu,lRv,lh,ilev,lEvs,ksyh, 

2 KSTart,ktOTAL,kOUNT,IPRG,GG,GGP, 

3 ILG1  , ILATH,CPA,KHEH, ALP,EPSI,LALP,WRKS,HRKL) 

* SAVES  SIGMA  LEVEL  GAUSSIAN  GRID  FORECAST  ON  FILE  NF2  . 

C"hpLEx  PHKLA,  1),UCLAW,  1),  V(LH,  l),ES(LA,n 

cohple*  PHism,psm,PEE(LA,i) 

DIMENSION  TMEAN(1),PEEPN(1) 

* GGP  IS  A hORk  FIELD  USED  ONLY  IF  FCST  IS  TO  BE  PACKED. 

* (IT  MAY  BE  FGUIVALENCEO  T«  GG  3 . 

DIMENSION  GG(l),GGP(I)#ALP(l),EPSI(l J#ORKL(l) 

DIMENSION  COA(t),WRKS(l) 

COMPLEX  PS1 

* OUTPUT  PACKING  DENSITIES  (SET  IN  MAIN  PROGRAM). 

COMMON/PKOUT/  nPGZ.NPSP,NPU,NPFS 

NSTEPSsKOUNT-KSTART 

ID=NSTEPS 

NLAT=ILATH 

IF(KHEM.EG.O)  NLAT=ILATh*2 

* no  prog  is  saved  tf  nverif=o.  otherwise  pr*g  is  saved  at 

* initial  and  final  times  and  *t  intervals  of  iprg  tjmfsteps. 

IF(IPRG.EQ.0.0R.NF2.EC,O)  OCTURN 
IF (FOUNT, EG, KTOTAL1  G"  T®  15J 
IF  (KO'JNT.EQ.KSTAPT)  GO  TO  150 
IF  (MOO  (NSTEPS, I PPG) .NE.O)  RETURN 

* CONVERT  LOG  OF  SURFACE  PRESSURE  FROM  (N/m**2)  TO  (M0). 

150  PSlsPS(l) 

PS(1)  s PS(l)+PS“N»AL0G(10O,)*SQRT (2.) 

CALL  SpAGG2(GG,lLGl,ILATH,C0A,KHFu,  PS  , LRS  , LM  , KSYM , 

1 alp,epsi,lalp,orks,wrkl) 

CALL  HSGGP (GG, ILG1 ,NLAT,NF  2,ID,4HLNSP,1 ,NPSP,GGP,URKS) 
PS(1)=PS1 

* CALCULATE  phi  FPOM  PEE  F«R  ILEV  LEVELS. 

* CONVERT  TO  GAUSSIAN  GRIDS  Anq  write  ON  FILE  Np2. 

CALL  GZF0P  (PHI,PEE,PS,TMEAN,PEEHN,PSMN,LA,L»S,LM,ILEV,RGAS) 

DO  310  L*l, ILEV 

CALL  SPAGG2(GG,ILG1  ,ILATH,COA,KHE'<,PHI  n,L),LRS,LM,KSYM, 

1 alp,epsi,lalp,hRks,wpkl) 
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CALL  wSgGP(GG,ILG1,NLAT,NF2,ID,0H  GZ , L , NPGZ , GGP , WRKS ) 

310  CONTINUE 

* CONVERT  U,V  TO  GALSSIAN  GRIDS  AND  SAVE  ON  NF2  . 

DO  010  L = 1 * ILEV 

CALL  SP*GG2(GG,lLGl,lLATH,CflA,KHEM,  uci»l),lru»lm,  KSVH, 
1 ALP, EPSI,LAIP, WRKS, WRKL) 

CALL  wSGGP(GG,ILGl,NLAT#NF2,ID,OH  U,L,NPW,GGP,WRKS) 

CALL  SpAGG2(GG,ILGl,IL*TH,COAfKHE^,  V ( 1 , L ) , L* V , LM, -KS YM , 

i alp,epsi,lalp,wrks,wrkl) 

CALL  WSGGP(GG,ILG1,NLAT,NF2,ID,4H  V , L , NPW, GGP , WRKS ) 

010  CONTINUE 

* convert  es  to  gaussian  grids  and  save  on  nf2, 

* MOISTURE  OMITTED  IF  LEVS30. 

IF (LEVS, EG. 0)  GO  TO  OR 
DO  510  N*1 , LEVS 
Ls(ILEV-LEVS)  ♦ N 

CALL  SPAGG2(GG,ILGi,lLATH,C0A,KHEM,  ES(1,N),LRS,LM,KSVM, 

1 ALP,EPSI,LALP,wRKS,WRKL) 

CALL  WSGGP(GG,ILG1,KLAT,NF2,ID,0H  ES , L , NPE S , GGP , wRKS J 
510  CONTINUE 

9<5  RETURN 
END 
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SUBROUTINE  SC0F2fSC»UR*LM#KINO) 

* ZERO  OR  DOUBLE  THE  COMPLEX  SPECTRAL  COEFFICIENTS  IN  SCCLR»LO) 

* DERENDING  ON  The  VALUE  OF  KIND. 

COMPLEX  SC(LRfl) 


* IF  KlNDsO  SET  ALL  flF  SC  TO  (0.,0.)t 

IF (KIND.NE.O)  GO  TO  3C 
DO  20  Msl.LM 
CO  20  n=1,LR 
20  SC(N,M)s(0.,0.) 

* IF  K I ND=2  DOUBLE  ALL  OF  SC. 

30  IF(KIND,NE.2)  GO  TO  R<5 
CO  40  Mai,  LM 
CO  40  N=1,LR 

40  SC(N»M)sSC(N,M)4SC(N#m) 

PR  RETURN 

END 


1-115 


SUBROUTINE  SEAFIXCTG»ESG*UG#VG,TMEAN#IIM*I10NG»IIEV,IEV3#DT» 

i siai,seacon#  Rgocp#3h*tsea,cbv) 

* FOR  IlONG  POINTS  ABOUT  ONE  GAUSSIAN  LATITUDE  CIRCLE 

* CALCULATES  CORRECTIONS  TO  TG,ESG  IN  LOWEST  LAYER  CAUSED  BY 
« SENSIBLE  HEAT  AND  MOISTURE  FLUXES  FROM  UNDERLYING  OCEAN. 

* SUCH  A PROCEDURE  IS  EQUIVALENT  TO  A LAGGING 

* OF  THE  FLUX  TERMS  IN  TIME. 

* TSEa  IS  sea  surface  temp  IN  DEGREES  K 

* COV  IS  FRACTION  of  land  in  grid  SQUARE 

CIMENSION  TG(lLM,n,ESG(lLM,l),UGCILMf  !),VG(ILM,1) 

DIMENSION  TMEAN(n*SH(l)#TSEA(l),COVCl) 

B0T2  e 5410. /(273. *273.) 

SECEXT*l./SH(lLEV)**RGOCP 

ILEVP-ILEV+1 

CO  100  IKsl.ILONG 

IF(C3V(IK).LE.O.)  GO  TO  100 
TLEV  ■ TG(IK.ILEVP)  ♦ TMEAN (ILEVP) 

OTSEA  = TSEA(IK)  - TLEV*SFCEXT 

wINCxSQRTc  UG(IK,ILEV)**2  ♦ VG(IK,ILEV)**2  ) 

FACTaC0V(IK)*SEAC0N*WIND*2.*DT/(TLEV*SlAl) 

IF  (CTSEA.LT.O.)  DTSEA«0.0 

TG{!K, ILEVP)  s TG(IK.TLEVP)  ♦ FACToDTSEA 

IF  (LEVS.EQ.O)  GO  TO  100 

QSOG  = SH(!LEV)aEXP(  R0T2  * ( TSEA  (IK)  - TLEV  ♦ ESGCIK#LEVS)  ) ) 
DTDSEA  = ( QS9Q  - 1.  ) / P 0 T 2 
IF  (DT0SEA.LT. 0.0)  CTCSEAsO.O 

ESG(Ik,LEVS)  s ESG  ( IK, LEVS)  ♦ F ACT*.  C HTSEA  - DTdSEA  ) 

100  continue 

RETURN 

END 
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SUBROUTINE  SECONDS 
xsn.n 

RETURN 

END 


SUBROUTINE  SETL (SCT/SCR»LA#ILEV) 

* COPIES  COMPLEX  SPECTRAL  coeff  in  SCF  INTO  SCT, 

* EACH  ARRAY  HAS  ILE V LEVELS  OF  LA  WORDS. 

* BOTH  ARRAYS  ARE  IN  LCM • 

COMPLEX  SCT(LA.n,SCF(LA»t) 


DO  20  Lei  * ILEV 
DO  20  MN»1,LA 
SCT(MN,L)sSCF(MN,Ll 


RETLRN 

END 


SUBROUTINE  SETOLD(PM,CM,PEEM,ESM,PSM,P,C,PEE,ES,PS,LA,ILEV,LEVS) 

* COPIES  CURRENT  VALUES  OF  P,C,PEE,E3,P3  INTO  THE  FIELDS  HOLDING 

* THE  previous  tihe  values  pm, cm, etc. 

COHPLEX  PM  (LA,  n,CH(LA,!)#PEEH(LA,l),ESMCLA,n»P3H(n 

COMPLEX  P(L*,1),  C(L*,1),  pee(l*,d#  es<la,i),  PS  C 1 ) 


CALL  SETL ( PM  , P ,L*,lLEV) 

CALL  SETL  ( CM  , C ,LA,IlEV) 

CALL  SETL(PEEM,PEE»LA,ILEV) 

CALL  SETL ( PSM,  PS, LA,  1 ) 

IF(LEVS.GT.O)  CALL  SE TL (E SM , E S , L A , LE VS ) 

RETURN 

END 


I 
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SUBROUTINE  SETZT  (PT.CT^EET.SOS.TOUM^EST.ESOUH, press, 

1 LA,LRS,IRA,IM,ILEV,LEV3) 

* INITIALIZES  SPECTRAL  ARRAyS  TO  ZERO  BEFORE  STARTING  THE 

* LATITUDE  LOOP  IN  THE  SPECTRAL  MULTILEVEL  MOCEL. 

« MOISTURE  VARIABLES  OMITTED  IF  LEVS  a 0. 

* if  model  is  hemispheric  pt  is  antisymmetric# 

* all  other  fields  are  symmetric. 

* EACH  LEVEL  IS  SEPARATED  BY  LA  COMPLEX  WORDS. 

COMPLEX  PT(LA#1),CT(LA,1),PEETCLA#1) 

COMPLEX  SDS(LA,1),TCUM(lA,1) 

COMPLEX  EST(LA,l),ESDUM(LA,l) 

COMPLEX  PRESS ( 1 ) 


DO  20  Lai , ILEV 

CALL  SC0F2C  PT(1,L)#LRA,LM,0) 

CALL  SC 0F2 ( CT(|,L)»LRS#LM,0) 

CALL  SC0F2(PEET(1,L),LRS,LM,0) 

CALL  SC0F2(  SDS(1,L)#LRS#LM,0) 

CALL  SC0F2CTDUM(i,L)»LRS»LM,0) 

20  CONTINUE 

CALL  SCOF2(TDUM<t,lLEVM),LRS,LM,o) 

CALL  SC0F2(PRESS,LRS,LM,0) 

IF  (LEVS.EO,  0)  GO  TO 
CO  73  L*1 #LEVS 

CALL  SC0F2(  EST(i,L)»LRS,LM,0) 

CALL  SC0F2(ESDUM(1,L),LRS#LM,0) 

73  CONTINUE 

99  RETURN 

end 


I 
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SUBROUTINE  SFORAG(PLTG»PVTG,UG#VG,TG#TMEAN,cnRAGG,lLM, ILEV#ILCNG, 
1 GRAV,A,PGAS,DS*SIAI) 

* ados  contribution  of  surface  prag  to  putg,pvtg 

* FCR  ILONG  POINTS  about  ONE  GAUSSIAN  LATITUDE  CIRCLE, 

DIMENSION  PUTGdLM#  1)»PVTG(ILM»  1)#UG(ILP#  i)»  VG(ILH#  i J 
DIMENSION  TGCIlm,  n,T>'EAN(n,CDRAGGCU#DS(n 


ilevp=ilev+i 

DO  20  IK=1,IL0NG 

FACT  s C0RAGG(IK)*GRAV*(A/SIAI)/(RGAS*DS(ILEV)) 
VMAGaSORT(  UG ( IK , ILE V ) »*2  ♦ VG ( IK , luE V ) **2  ) 

FACT  s FACT  * VMic  / C TG ( I K , ILE VP ) tT*E *N  ( ILE VP  ) ) 
PUTG(IK, ILEV)sPUTG(IK, ILEV)fFACT*vG(IK,  ILEV) 
PVTG(IKf ILEV)sPVTG(IK,ILEV)-FACT*LG(IK,ILEV) 

20  CONTINUE 

RETURN 

END 
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SUBROUTINE  SGTPRE (FX , FOE R , S IGM A , SP , L * , LB , PRL , L V , SG, F , G , NN , GL APSE , 

1 EXTRAP#KINd,gZPI,SFCPI) 

* EXTRAPel.  FOR  HEIGHTS  AND  TEMP,  0.  FOR  WINDS. 

* GLAPSE  IS  LAPSE  RATE  PELOw  SIGma*1.  SELECT  SOME  POSITIVE  VALLE 

* FOR  geopotentials,  set  TO  ZERO  FOR  all  other  variables. 

* GZP I ■ GZ  INITIAL  ON  PR  SFC.  SFCPI*  INITIAL  LN (SF  PRES). 

* KlNOal  RETURNS  VERTICAL  DERIVATIVE  in  FDER.  (OFF  IF  KINQbO) 

* NOTE  - IF  LAsLP,  FX  OR  FDER  HAY  BE  EQUI V AlENCED  TO  SIGMA, 

SgTPRT  COES  VERTICAL  INTERPOLATION  on  a field  sigma,  ASSUMED  known  on 
NN  S IGMA  LEVELS  at  la  POINTS  PFP  LFVEL,  STORED  CONSECUTIVELY, 
PRODUCING  AN  OUTPUT  FX(LA,LV),  LOCATED  AT  THE  Same  HORIZONTAL  POINTS, 
BUT  at  the  PRESSURE  LEVELS  LOCATED  by  PRL(LV),  INTERPOLATION  is  pone 
using  the  LOGARITHM  of  PRESSURE/SIGMA  AS  THE  VERTICAL  COORDINATE. 
FDER(LA,LV)  CONTAINS  THE  VERTICAL  DERIVATIVE  OF  FX  IF  KINQ=1. 

SP(LA)  is  A field  OF  log  of  surface  pressure#  for  sigma/pressure 
Conversion,  prlog  is  the  log  of  the  desired  pressure  level#  (in  the 
same  units  as  SP)  while  sg(nn)  contains  the  logs  of  the  sigma  levels, 
note  that  DIFFERENT  SIGMA  levels  are  stored  LB  POINTS  APART  in  sigma. 

NOTE  ALSO  that  IF  The  FIELD  SP  IS  O.o,  THE  ROUTINE  CAN  BE  THOUGHT  OF 
AS  A RElATIVElV  general  PURPOSE  INTERPOLATOR,  GIVING  fields  at  The 
COORDINATE  PRLOG,  IN  TERMS  OF  FIELDS  AT  THE  COORDINATES  SG(NN). 

DIMENSION  FX(LA,LV) ,FDEP(La,LV),GZPI (LA#LV) 

dimension  sigma(lb,nnd,sp(la),sfcpi (L*> 

DIMENSION  SG(NN),FCNN),G(NN),PRL(LV) 

TOLAPSsO. 

SEnTRsO  ,5 

DO  20  I*|,  LA 

CO  10  Ns  1 , NN 
10  f(N)  s SIGMA(I,N) 

CALL  TSIG(G,F,SG,NN,T0LAPS,SFNTR,2.0) 

DO  20  L=1,LV 
X = PRL(L)  - SP(I) 

IF(EXTRAP.GT.0.)  xIaPPL(L)-SPCPI(n 
IF(EXTRAP.GT.O.)  FIsG2PI(I,L) 

CALL  TEPP2E (FXIL,DERIV,X,F,G,SG,NN,EXTHaP,GLAPSe,FI,XI) 
FX(I,L)*FXIL 

IF(KIND.EO.l)  FDER(I,L)sDERIV 
20  CONTINUE 

RETURN 

END 
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SUBROUTINE  Sm8v2(Qc,LRC,0I,l*I*LH) 


* FILLS  C'MPLtX  f3C(LpC»LH)  FRO''  QKLrIiLm)  BY  EXTRACTING 

* ThE  FIRST  LrC  COMPLEX  *8RDS  FROM  e4CH  ROW  OF  QI. 

* NOTE  - URC  SWOl'LC  NOT  EXCEED  LpI, 

CCMFLEX  QC(LRC#n,CICLRl»l) 


C8  210  m s l , L W 
CC  210  N* 1 # LRC 
2lf)  fiCCN,  MjsOI  (N,M) 


RETlRN 

END 
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SUBROUTINE  5PAF2(CFC,SC,LR,LM,AIP,LAIP) 


« CALCULATES  COMPLEX  FOURIER  COEFFICIENTS  IN  CFc(LH) 

* FROM  SPECTRAL  COEFFICIENTS  IN  SC(LR#LM). 

* CFC  WILL  CONTAIN  WAVES  0 TO  CLM-1). 

* IF  SC  IS  GLOBAL,  RO*  1 CONTAINS  WAVES  0 , 1 , 2 . . . C LR- U t 

* IF  SC  IS  SYMMETRIC,  ROW  1 CONTAINS  WAVES  0,2,4. , .2* CLR-1 1 . 

* IF  SC  IS  ANTISYMMETRIC,  ROW  1 CONTAINS  WAVES  1 , 3, 5 . . .2*  (LR-  1)  ♦ 1 

* ALP(LALP,LM)  CONTAINS  LFGENDPE  POLYNOMIALS  FOR  ONE  LATITUDE. 

* ITS  ROWS  MUST  HAVE  TmF.  Same  STRUCTURE  AS  THOSE  OF  SC. 


complex  cfc(1),sc(lr* n 

DIMENSION  ALP(LALP.l) 


CO  30  Msl,LM 
FCR=0. 

FC I = 0 , 

DO  20  N=1,LR 

FCR  = fcR  + ALP(N,m).  REAL (SC  (N,M)  T 
FCIsFCI*ALp(N,m)*aImaP(SC(N,M)5 

20  CONTINUE 

CFC(M)=CMPUX(FCR,rcl) 

30  CONTINUE 

RETURN 
E 
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SUBROUTINE  SFAGG2  (GG,  ILG1 , JlATH,COA/K>*Ef',f’<LR,t-M,KSM( 
1 ALP,EPSI,LAUP,«RKS,wRKL) 


* produces  Gaussian  grid  from  spectral  cceff  in  p<iR,m. 

* IF  GLOBAL  GG»CILG1»1L‘th*25,  OTHERWISE  GG  = ( ZLG 1 , HATH) . 

* L A T I TcCE  IS  ZERO  AT  LEFT  OF  GRID  ANC  POSITIVE  EASTWARD , 

* LEFT  COLUMN  IS  COPIED  INTO  THE  RIGHT  COLUMN, 

« ki-Eu  0 s GLOBAL.  I s N HEM  ONLY,  2 s S HEM  OnLY. 

* KSH  ♦iaSYMvETRlC.  nsGLOBAL,  - 1 « ANT  I S Y«mE Tr IC 

* COA(ILATH)  CONTAINS  ThE  COSINES  OF  THE  ^LATITUDE  (N  TO  S). 
« ALP(LALP,LU)  IS  a **°K  FIELD  FOR  LEGENDRE  POLYNOMIALS, 

* E F S I IS  A FIELD  'F  CONSTANTS  The  Same  SIZE  AS  ALP. 

« *RkS  , *bkl  ARE  SC  h , L C h h*R»<  ARRAYS  OF  (IlG+2)  nORDS, 

* PAST  r OU® I E R TRANSFORM  REDUCES  THAT  I LG  BE  A POWER  OF  2, 

complex  P(l) 

dimension  ggcilgi,  n .coach 

DI“ENSION  ALP(  1)  .EPS! ( 1 ),*RKSC1),*RKL (1) 

ILGslLGl-l 
IlGHs IlG/2 

maxFsL^-I 
I L f*  = 1 

IF(kSm.lT.o)  ILFslaLp/2*1 

* CO  NORTHERN  I F REVESTED  (KhEMsO  OR  1). 

IF  (Kh£m  ,EG, 2)  GO  TO  IS 
DO  JO  Ihsi , IlaTh 
SlNLATsfOA(lM) 

J»XsIlATh+ J-Ih 
IF tN-EM.EG,0)  JRXsjFXtlLATH 

call  ALPNu2(ALP,LALF,LM/SINLAT,EPSn 

IF(kSm,ne.05  call  alpaS2CALd,LALP,Lh.''RkS) 

CAUL  SPaF2(.Rkl,p,Lr#L“, alp (Il°) .lalpj 

CALL  FFGF«2CGGCl,JRX),lLGl,.'RKL,lLGM(MAXF,lLG/wRKS,n 

GGCILGI, JRXJaGGCl, JRX) 

30  continue 

* DO  SOUTHERN  h£hjSchfb£  j f RECleSTEO  (**£“  = 0 or  2). 

3S  IF  (KH£MtEr t ] ) RETURN 
DC  u 0 Ihsi,IlaTh 
SINLAT=-C0A (I-) 

JRX  = Ih 

CALL  ALF''“2CALF,LALF,Lu,S;NLAT,Ct'SI) 

IF(kS“,nE,0)  CALL  alpaS2CaLc,LAlP,LH,wRkS) 

CALL  SPaF2  (hR-'l,b/lR  ,LH,  alp  ClLp)  ,LALP) 

CALL  PFGF-2 (GG (l, JRXl , ItGi , «RKL, ILGh.maxF, ILGi WRKS,  i ) 

GGCILGI,  JRX)sGGn,JcX) 
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40  CONTINUE 
RETURN 
END 


! 
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SUBROUTINE  SPAPS2(G#NI,nJ,IP, JP#060,0GPw,NHEM,P,LR»Lm#K3m» 

1 AUP#EPSI»LALP»WRKS#WRKL) 

* CALCULATES  P"LAR  STEREOGRAPHS  GRID  G(NI,NJ)  WITH  POLE  (IP,JP) 

* FROM  COMPLEX  SPECTRAL  COEFF  IN  P(LR#LM). 

* PS  GRID  SIZE  IS  ASSUMED  TO  BE  D60  H£TERS. 

* PS  GRIO  ORIENTATION  has  ZERO  DEGREES  LONG.  AT  (OGRN ) DEGREES. 

* NHEM  1 = NORTHERN  HEMiSPHfRE.  nmEM  2 s SOUTHERN  HEMISPHERE, 

* *lp(lalp#lm)  is  a work  field  for  lEGEnore  polynomials. 

* EPSI  IS  A FIELD  OF  CONSTANTS  THE  SAME  SIZE  AS  ALP. 

* WRKS  IS  AN  SCM  WORK  FIELD  OF  LALP  WORDS. 

* WRKL  is  an  lcm  WORK  field  of  Lu  complex  WORDS. 

COMPLEX  pci) 

dimension  g(ni,nj),cpsi(1),alp(1) 

DIMENSION  WRK$(l),WfiKL(l) 

CRC0Ns3. 14159/180. 

MAXF  sLM-1 
ILP=1 

IF(KSM.LT.O)  ILPsLALP/2+1 

* set  GRID  to  LARGE  INITIAL  value. 

GF ILLs 1 , 1 1E+75 
DO  10  J=1,NJ 
DO  10  1 = 1, NI 
10  G(I,J)=GFILL 

* LOOP  OVER  the  entire  GRID. 

DO  20  J= 1 , N J 
JYsJ-JP 
VPs  J Y 

DO  20  1=1, NI 
IX=I-IP 
XP  = IX 

IF(G(I,J).NE.GFILL)  go  to  20 

* obtain  the  latitude  of  point  c i , j ) and  get  the  fourier  coeff 

* for  that  lat  from  thf  spectral  coeff  in  p. 

CALL  LlFXY(DLAT,OLON,XP, YP,D60,DGRW,NHEM) 

SINLAT=SIN(DLAT*DRCeN) 

CALL  ALPNM2(ALP,LALF,LM,SINLAT,F.PSI) 

IF(KSM.NE.O)  CALL  ALPAS2CALP, LALP, LM, WRKS) 

CALL  SPAF2(WRKL,P,LR,LM,ALP(ILP) ,LALP) 

* GET  THE  COORDINATES  OF  EACH  OF  THE  POSSIBLE  EIGHT  POINTS 

* in  the  grid  that  lie  on  the  given  lat  circle. 
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IlxIPtlX 
JJsJP+JY 
X = XP 

Y = YP 

ASSIGN  12  TP  NP T 

GP  TP  19 

12  II=IP-IX 
Xs-XP 

ASSIGN  13  TP  HPT 
GP  TP  19 

13  JJaJP.JY 

Y = -YP 

ASSIGN  ia  TP  NPT 
GP  TP  19 
19  IIsIP+IX 
X = XP 

ASSIGN  15  TP  MPT 
GP  TP  19 

15  IIsIP+JY 
JJ=JP+IX 
X = YP 

Y = XP 

ASSIGN  16  TP  MPT 
GP  TP  19 

16  IIsIP.JY 
Xb-YP 

ASSIGN  17  TP  NPT 
GP  TP  19 

17  JJaJP-IX 

Y = -XP 

ASSIGN  lfl  TP  NPT 
GP  Tp  19 

18  IIsIP+JY 
X=YP 

ASSIGN  2«  TP  NPT 

* Make;  sure  ppint  IS  gPTH  inside  grid  and  NPT  already  DPNE. 

* GET  LPNGITUPE  *ND  EVALUATE  fPURieR  SERIES  AT  THAT  PpjNT. 

19  IF(II.LT.l.PR.II.GT.NI)  GP  TP  195 
IFCJJ.LT.l.PR.JJ.GT.NJI  GP  TP  195 
IF(G(II,JJ).NE.GFILL)  GP  TP  195 

CALL  LLFXY(DLAT,DLPN,X,Y,C60,DGRU,NHEM) 

RLPNsDLf'N*DRCPN 

CALL  CFVAL2(  GIJ  , KRk  L , A XF  , RL  PN  ) 

G C 1 1 * JJ)=GIJ 

195  GP  TP  NPT, (12, 13, 19,15,16,17,18,20) 

20  cpntinue 
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FLNCTI5K  SPC«..M(Tr,P) 


* C3MP-TES  SPECIFIC  *“L^iriTV  *SpC*UH*  USING 

« DE*  PSINT  TPmpepaTlPE  Tr  ASCI  PRESSURE  P ( “ e 5 

* E IS  Tv-e  V a P 3 p PRESSURE  RELATED  T9  TC  PY 

* EsEXP C A-R/TD) 

* P ? R SAT*.RATifs  values  TRLE  TE“PERaTlRE  REPLACES  T[>  IS  yajs 
C?*Y3S/EpS/A,6,EPSl  ,EpS2 

t=EXP(A-E/TD) 

SpC^uMsEpSl*E/(D-LPSe*E3 

RLTLSS 

t *.[■ 


SUBROUTINE  SPLAB(NF,KIND,LV,PR,NK,SIG,LEVS,IIG,  ILAT,KHEM,IR,DeET, 
1 mtN,weT,kdR,kaT,kcV,KdIV,KSTART,KTOTAL,IPRG,IPCP. IDATIM) 

* THIS  SUBROUTINE  REACS/WRITES  the  CONTROL  LABEL  for  THE 

* SPECTRAL  MODEL  program  sequence  on  file  nf. 

* KlNOsl  READS,  KIND»2  WRITES. 

* PR(LV)  CONTAINS  the  L v INITIAL  PRESSURE  LEVELS. 

* SIG(NK)  CONTAINS  THT  NK  MODEL  SIGMA  LEVELS. 

* LEVS  IS  THE  NUMreR  OF  MOISTURE  LEVELS  USED  IN  THE  MODEL. 

* CILG+1.ILAT)  s GALSSIAN  GRID  DIMENSIONS  (GLOBAL). 

* KHEM  ijsGLOBAL,  1 s\  HEm,  2aS  H£M. 

* IR.DEET  = MODEL  RESOLUTION  AND  TIMESTEP, 

* mtn(heT,KDR,kwt,kcV,«DIV  ARE  LOGICAL  SWITCHES  FOR  MOUNTAINS, 

* MOISTURE, DRAG, water. TEMP, SEA-COVER, INITIAL  DIVERGENCE. 

* KSTART,KTOTAL  s MODEL  STARTING  AND  ENDING  TIMESTEP  NUMBERS. 

* IPRG.IPCP  s FORECAST  aND  PRECIP  SAVE  INTERVALS. 

* INITIAL  DATE  TIME  GROUP  IS  IN  IDATIM 

DIME  NS  I ON  PR(LV),SIG (NK), IDATIM (la) 

iogical  mtn,wet,kdr,k*t,kcv,kdiv 

data  HEADER, IDFNT, NAME / aHLABL,  0,  aHINFO  / 

REWIND  NF 

* READ  the  LABEL  IF  KIN0=1. 

IF(KIND.tn.l)  PEAD(NF)  HEAC,ID,INF0, 

1 LV,(PR(L),L=1,LV),NK, (SIG(N),N=1,Nk),LEVS,DEET, 

2 ILG, ILAT,khEM,IR,mTN,WET,KDR,KWT,KCV,KOIV, 

3 KSTART,WTOTAL , IPRG, IPCP,  IDATIM 
IF(KIND.ED.l)  WRITER, 6310)  NF 

* WRITE  THE  LABEL  IF  K I N D s 2 , 

IF (KIND. EQ. 2)  WPITE(NF)  HEADER, IPENT, NAME, 

1 LV, (PR(L),L=1 ,LV),NK, (SIG(N),N=1,NK),LEVS,DEET, 

2 ilg,ilat,khem,ir,mtn,wet,kdr,kwt,kcv,kdiv, 

3 KST ART, KTO T AL, IPRG, I PCP, IDATIM 
IF (KIND. EQ. 2)  WRITE (6,fco20)  ME 

* PRINT  OUT  all  LABEL  information. 

30  wRITE(6,6030)  LV,PR 
WRITE (6,6032)  NK,SIC 

WRITE (6,6O«0)  LEVS, ILG, ILAT, KHEM, IP, DEET 
WRITE (o,60A5)  HTN,WET,KnR,KWT,KCV,KDIV 
wPITE (6,6050)  KSTART,wTOTAL,IPPG,IPCP 

wRITE(6,6060)  IDATIM 

return 
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6010  FCR^aT  C31H0SPECTP&L  LABEL  RFAD  FROM  FILL, la) 

6020  FPR^‘ATC3lHnSPFCTRAl.  LABEL  WRITTEN  TO  FILE, 10) 

6030  FPR*AT(22H  INITIAL  PRESSURES  ,I5,15F6.0) 

6032  F0RF'ATf22H  HflDEL  SIGNA  LEVELS  ,I5,15F6.3) 

600P  FORMAT  (2Rh  LEVS,ILG,IHT,KHEM,IR#0EETs#SI5,Fe,2) 

6005  F0RPATC2RH  MTU  , K£  T , Kf;R  , K ;T  , KC  V , KD I V =,6L5) 

6050  F ORf'  A T C2RH  KSTART,VT"TAL,  IPRG,  IPCP  =,015) 

6060  FORMAT  (22H  DATE-TINE  GPOljP  , 2X , 6 I 3 , 7 AO , II  2 ) 

END 


I 
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SUBROUTINE  SPLaT2(a,LI,nc,II* INCR»GMIN,RMaX) 

* PLOTS  UP  TO  6 CURVES  ON  THE  SAME  GRAPH. 

* PL"TS  EVERY  INCR  POINTS  FROM  1 TO  II  IN  A(LI.NC) 

« CURVES  1 TO  b USE  SYMBOLS  A,B,C,D,E,F. 

* VALUE  of  LAST  CURVE  WRITTEN  ALONG  X-AXIS  UNLESS  INCR  IS  NEGATIVE 

* NO  GRAPH  drawn  if  incr*o  OR  NC=0. 

* GRAPH  LIMITS  GMIN,GMAX  AND  MIDDLE  VALUE  PRINTED  AT  START  AND  END 

* IF  GMIN=GMAX  GRAPH  LIMITS  CALCULATED  FIRST. 

« IF  THE  RANGE  IS  STILL  ZERO,  IT  IS  RESET  TO  1. 

DIMENSION  ACLI.NC) 

INTEGER  NG(101)#S(«)»IGR(ft) 

DATA  S/1H  , 1HI, 1H-, 1M*/ 

DATA  IGR/1HA.1HB, 1HC.1HP,  IHL.IHF/ 


IF(INCR.EO.O.OR.NC.EQ.O)  GO  TO  9<? 
INCslABS(INCP) 

A^INsGMIN 
AmAXsGM AX 

IF(Amin.LT.AMAX)  GO  TO  1A 
A M I N * A ( I , l ) 

AMAX=AMIN 

CO  12  J=1,NC 
DO  12  1=1, II, INC 
T* A ( I , J ) 

IF(T.LT.AHIN)  AHINsT 
IF  (T.GT.AMAX)  4 A X s T 
12  CONTINUE 

IF(AMIN,F.Q.AMAX)  AMAXaAMlN+1. 

\U  RANGEaAMAX-AMIN 
04100=100. /RANGE 

AX=(AMAX*AMIN)*.5 

WRITE(6,605)  IGR(NC)#RANGE 
WRITECR/610)  AMIN,AX,AMAX 
WRITE(6,615) 

DO  2a  Isl,lI,INC 
DO  15  K = 1 , 1 0 1 
15  NGCK)sS(l) 

NG(51)=S(2) 

IF(I/lO*lo.EO.I)  NG (5 1 ) =S  (3 ) 

DO  20  J s 1 , NC 

Y*CA(I,J)-AMIN)«DA100a1.5 

K=INT(Y) 

IF(K.GE.I.ANP.K.LE.IOI)  NG(K)»IGR(J) 

20  CONTINUE 

IF (INCR.GT.O)  WRITE (6 , 62n ) I»A(I,NC),NG 
IF (INCR.LT.O)  wR I Tr  (b , 625 ) NG 
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SUBROUTINE  SPMClN(S,SH,SF,SHF,DS,DEl,FVORT,PI,GiMMA,ILEV) 
a SETS  CONSTANTS  FOR  THE  MULTILEVEL  SPECTRAL  MODEL. 
CIMENSION  S(n#SHU),SF(t),SHFCn,DS(n#DEL(U 

C OHM 9N/P ARAMS/  ww#th,A,4SQ,GRAV,RG4S»RCOCP,RGO*SO#CPRES 
ILEVH  = ILEV-1 

* ww  s EARTH  rotation  RATE  (1/SEC). 

* A = EARTH  RADIUS  (M). 

a GRAV  = GRAVITY  ACCELERATION  (m/SEC**2). 

a RGAS  s DRY  AIR  gas  CONSTANT  (JOULE/(KG*DEG) ) . 

A RGOCP  = RGAS/CORY  air  SPFCIFIC  HEAT) 

a GAMMA  r L APSE  RATE  FROM  THE  LOWEST  LAYER  TO  THE  SURFACE 


*Ws7.2R2E-5 

TwsWW+WW 

GAMOAs5.90E-03 

A=6.37122E06 

ASQsAaA 

GRAVsR.POhlb 
RGAS  = 2B7.0<J 
RG0CP=2./7. 

RGPASU=RGAS/ASO 

CPRESsRGAS/RGOCP 

a FVORT  s VORTICITY  OF  EARTH  ROTATION. 

PI=3.iat5R26535aR7 
FVORTsTwaSORT (2 , / 3 . ) 

* s = sigma  at  the  "td  levels. 

* SH  = SIGMA  AT  TmE  EVE"  LEVELS 

a DS  s DELTASIGMA  BLT.EFN  EVEN  LEVFLS, 

CO  30  iHsl, ILEVH 
30  CEl(IH)  = S(IH+1)  - S(IH) 

DEL (ILEV)  si.-  3(ILEV) 

DO  <10  IH  = 1,  ILEVH 
<40  SH(IH)  = SQRT(SCIH)ASCIHM)) 

SM(ILEV)  s SQRT  (S  ( ILE V ) ) 

CS(1)  s SH(t) 

DO  50  Ih*2, ILEVH 
50  DS(IH)  s SH(IM)-SH(IH-1) 

OS  c ILE V ) S l.-SH(ILEVM) 

DO  60  iHsl, ILEVH 
60  SF(IH)  = AL0G(SCIH+1)/S(IH)) 

SF(ILEV)  s AL0GC1 ./S(ILEV)) 


» 


DP  70  IH=1,IIEVK 

70  SHF(IH)sALPG(SH(lH*l)/SH(IH)) 
3HF(ILEV)**L8G(1./SH(ILEV)  J 
RETURN 
END 
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SUBROUTINE  SPW*(ILG, ILAT,KHE^, IR, ILEV,LEVS,S, 

1 NFl,NF2,NFPCP,LC,ET0TS,lTflT,IEPR*N0GR,IPR, 

2 N‘TE$T,IPRG,IPCP,NPPCP,IDaTIM) 

* SPECTRiL  IMPLICIT  MUITILFVEL  WfT  MODEL  - VEPSION  6. 

* for  a complete  description  of  this  program,  see,... 

* (THE  D.P.R,  MULTILEVEL  SPECTRAL  model  program  - VERSION  fc) 

* AND  OTHER  DOCUMENTS  (AVAILABLE  AT  D.P.R.  MONTREAL,  CANADA). 

* NF1  = INPUT  FILE  FOR  ALL  VARIABLES  AND  PHYSICS  GRIDS. 

* nF2  = output  file  for  phi, phis, lnsp,u,v,es. 

* NFPCP  = OUTPUT  FILE  FOR  PRECIPITATION. 

* i/o  arrays  and  parameters. 

DIMENSION  LC(n,ETOTS(LTOT,<j),lDATIM(iU) 

LOGICAL  mtn,wet,kdR,kuT,KCV,KDIV 
COMM ON/SRC OH/  MTN,wET,KDR,KWT,KCV,KDIV 

* LCM  COMPLEX  MULTILEVEL  ARRAYS 

parameter  SILV*i5,JLEVso,fLVsio,$ILTa?2,SILGa6«,SILTHs26,«IR*20 
PARAMETER  $L A s (SIR+2) a(SIR+1) 
parameter  *LAw  = raaIIlV 
PARAMETER  SLAX  s $la*($lEV+1) 

PARAMETER  IIL1  S 1 1 L V ♦ 1 
PARAMETER  SL*1  S JLAMIL1 
PARAMETER  JLGG  = «ILG*$ILT 
PARAMETER  ILGP  = (SILG0?)*»ILT 
PARAMETtP  SIRL  = (2* JIR+1 )*SILV 
PARAMETER  SCR  s >ilc*silv 
PARAMETER  SCS  s llLG*(»LEV  + n 
PARAMETER  SCR  1 S SILGaJILI 
PARAMETER  JILG3  S S I LG  ♦ 2 

COMPLEX  P,C,PEE,PS,  pm, CM, PCEM,P$M,  PT,CT,PEET 
complex  u,v,phi,t,scs,es,esm,est 

COMMON//P  (SLAW)  ,c  ( * L A lo ) , PEE  (Jl4*),RS(SL  A)  ,PM  (SLAW)  »CM(  HAtO  • 

* PEEM(JLAw),PSM(jla),pT(SLAw),CT(sLAw),PEET(sLAh),U(ILAh),V(sLA^), 
*PMl(«Lwn,T(SLWl),SCS(SLAw),ES(SLAX),ESM(sLAX),EST(SLAX) 
complex  TDUHn  ),Din),pEEBAB(l),ESDUH(l) 

EQUIVALENCE  fTcLM,PHl), (DI,V), (PEEPAR,SDS), (ESDIJM,PEE) 

* LCM  PHYSICS  - 1 LEVEL  COMPLEX  ARRAYS 

COMPLEX  Phis, press 
COMMON//PmIS(SLA),PRESS(JLA) 

* lcm  physics  - gaussiah  grids  and  work  rows. 

C0MMflN/GGP4K/DRPAK(!LGP),WTPAK($LGP),CVPAK( JLGP),PCPPAK(SLGP), 
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*STBPAK(SLGP) 


* LC*  WORK  ARRAYS 

C0MMON/ALPCOm/ALP(*L*)  »D4LP  (*LA)  ,EPSI  (H*) 

CeMf'<JN//Ai(SIRL)»PI(*IRL)#Cl(tIRl),WRKLC300) 

CfMMON//PRtSSG(iILG),°SnLG($lLG) ,PSDPG(UILG),CUMDUM($ILG), 
*PG(!CR),CG($CR), 

*TG(JCR1),UG(SCR),VG  ( JC«)»EG(SCR),PUTG(SCR)»PVTG($CP)»TUTG(SCr)» 
*TVTG(!tCR),ESG(fCS),FEETG(*CR),SDSG(JCR),AMBDPG($CR),flMEGAG(JCR) 
DIMENSION  SUSG(l),SVSG(l)»ESTG(l) 

EQUIVALENCE  (SUSG(1),PG(1)),(SVSG(1),CG(1)), (ESTG(1),AMBDPG(1  )) 
DIMENSION  GLL(l) 

EQUIVALENCE  CGLL(n»PRESSG(l)) 

* SC*  MJRK  AND  I/O  FIELDS. 

COMKIJN/GAUSS/W  («ILTP)  ,WOCS  (SlLTH)  ,COA  (IILTH)  ,SI  A ($ILTH)  ,RAD  (SILTH) 
COMMON/SCMl/wRKS(tILG3,P) 

* THE  FOLLOWING  ARRAY*  4RE  pfiR  FUNCTIONS  OF  ILEV. 

* CURRENTLY  SET  FOR  A MAXI  RUM  OF  10  LEVELS. 

COMPLEX  P2CSILV) 

DIMENSION  STAMS(5ILl»!lLl)#STAIStSlLl»*ILl),STAwS($ILl#6), 
*RCPSHD(SILV),AMBCA(JIL1),PEEMNC$ILV),RK(SILV),TMEAN($IL1), 
*S(SlLV),SH(SlLV),SF(SILV),ShF(SILV),DS(SlLV),CEL($lLV),TflTK(SlLV) 

* SCM  common  BLOCKS  for  MODEL  parameters 

COMMON /TI^ES/  DEET,KOlNT,KSTAPT,KTflTAL»IFPIFF 
COMMON/PARAMS/  ww,tw,a,asq,ghav,rgas,rgocp,rgoasq,cppes 
COMMON  /PARAM2/  BETA,AVFRT,DIVCH,FP,FC,FPEE,FPS,FS 
COMMOn/PARAMJ/  DIFUSD,CIFUSS,VIFUSS 
COMMON/PARAM«/  ceeach.rkl 


OAT  A NP0R*NPWT,*IPCV»NPPCM/1 , 1,1,1/ 

* SECTION  1 - CONSTANTS  AND  DATA  PREPARATION. 

IF (NTEST.NE.O)  CALL  SEC"N0(SEC2) 

WRITE (6,b005) 

WRITE (6,6010)  KSTART,KTOTAL,IFCIFF 

wRITE (6,6012)  DFET,PETA,DIVCH,FP,FC,FPEE,FPS,FS 

WRITE (6,60 12)  0 IFUSC, DIFUSS, CEE  ACM, RKL 

* CALCULATE  CONSTANTS. 

KOUNTsKSTART 

ILEVPalLEVM 
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T 


ILATHsILAT/2 

ILG 1 * ILG+  1 

LTBS=ILEV-LEVS 

ILMsILG 

ILHslLH/2 

KSVH*o 

IF (KHEM ,NE  , 0 ) KSYMsl 
DTsCEET 

IF ( IFDIFF  ,EQ  , 1 ) DTsDEET/2. 

CALL  DIMCALCLRS,LRA,LPU,LRV,LALP,LM,LA,LAH,IR,KHf:M) 

WRITE (6,6015)  LR8#LRA,LRU,LRV,LALP,LH,LA,LAW 

CALL  SPhcBNCS, SH.SFiShF, OS, DEL* FVQRT.PI, GAMMa, ItEV) 

C*LL  epsil2(epsi,lalp,lh) 

CALL  GAUSSG(ILATM,CflA,W,SlA,RA0,W5CS) 

CALL  PHSC1N(SEACDN,RK,CEEACH,RKL,BETA,S,DEL,ILEV) 

IF  C WET) CALL  «E Tc ON ( S T a WS , RcPSHO , S , SH , SF , DEL , RG8cP , ILF V- 1 , LE V 5 ) 
CALL  STmCAl  (STAMS,«TAIS,S,SF',SF,SHF,RGI)CP, 

1 RGAS,GRAV,GAMMA, ILEV, ILEVP,EXTRAP) 

* READ  INPUT  FIELDS  FRO"  SEGLENTIaL  FILE  NF 1 . 

CALL  INPTGG(NFi,NF2,0RPAK, WTP4K,CVPAKf ILGl,ILATH,KHEM, 

1 KDR,KWT,KCV,NPrR,NPWT,NPCV,GLL,PM,wRKS) 

IDsKSTART 

CALI  INPTSP (NF 1, ID, AF2, PHIS ,PS,PHI,P,C,ES,L A, LRS,LR A, 

1 LM,ILEV,LEVS,KMEM,ILG1, ILATM,COA,w,wOCS,GLL,PM,PT, 

2 ALP,DALP,EPSl,LALP,WRKS,wRKL) 

* set  INITIAL  DIVERGENCE  T8  ZeP8  IF  ReGUESTed. 

IFC.N3T.KDIV)  CALL  SC8F 2 (C , L A , ILE V , 0 ) 

* COMPUTE  T FROM  GZ,  SET  TO  T-PRjme,  SAVE  MEANS  IN  TMEANH, 

CALL  TFGZ(T,PHI,PhIS,LA,LRS,LM,ILEV,SF,RGAS,S,GPav,GAmma) 

on  150  L*lfILEVP 

ns(L-J)*LA+1 

TMEAN(L)sREAL(T(N))/SGRTC2.) 

150  T{N)*(0,,0.) 

CALL  TMCAL(Tmean.amR0A,S,SH,SF,RG3CP,STams, ILEV.ILEVP) 

CALL  PRLMAT(RGAS,RG8CP,S,SH,SF,SHF,  AM0DA,TMEAN,GRAV,GAMMA, ILEV) 

* SET  PS  T 3 PS-PPIME,  SAVE  MEAN  IN  PSMN. 

PSHNsPSCl) 

PS(1)=(0.,0.) 

PSMNR2sPSMN/SQRT(2. ) 

* COMPUTE  means  3F  PEE  FROm  GZ.  STBRE  IN  PEEMN. 
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CP  100  L= 1 , ILEV 
Ns(L-l)*LAM 

160  PEEHN(l)=REAl(PHI  (N)  ) ♦ RG A S* THE  AN { L ) *p S^N 

* SECTI3N  2 - BEGIN  time  STEP.  CALCULATE  (U,V)  FROM  (P,C), 

200  IF(NTEST.EQ.O)  G"  TO  210 
SEC1=SFC2 
CALL  SECOND  (SEC2 ) 

TIMEsSEC2-SEC1 
HRsKOUNT*DF ET/3600. 

“■RITE  (6,6020)  K9UNT,HP,TIwf 

210  CO  220  Lsl, ILEV 
NUV=(e-1)*LAw+1 
NPCs(L-l)*LA  +1 

CALL  QnAw2(UCNUV),VCNLV),P(’iPC),C(NPC),EpSI,wR«S(l/l),*RKSn,2), 
1 LpU,L°V,LBA,L«S,LALP,Lf<#KHFM,IB) 

22 0 CONTINUE 

* ACO  EARTH  rotation  to  v^RTICITY.  SET  TENDENCIES  TO  zero. 

CO  210  LSI,  ILEV 
N=(L-1 )*LA+2-KSYH 
P2(L)sp(N) 

230  P(N)sP(N)+CHPLX(FVPRT,0.) 

CO  2U0  l=i»ilev 

200  TOTK(l)sO. 

CALL  SFtZT  (PT,CT,PEET,SDS,TDUP,EST,ESDUM#PRESS, 

1 l A,LRS,LRA,L»‘,  ILEV, l EVS) 

« SECTION  3 - LATITUDE  LOOP. 

* THE  NORTHERN  HEMISPHERE  IS  DONE  FIRST,  FOLLOWED  BY  THE 

* southern  hemisphere,  either  CAN  8E  omitted  if  not  needed. 

* NHs I FOR  NORTHERN  HehiSPHErE,  NHs2  FOR  SOUTHERN  HEMISPHERE. 


NUPSsO 

NSUPSsO 

DO  720  NHs 1 ,2 

IF  (NH.FQ.l  ,ANri,KHEM  .EG, 2)  GO  TO  720 
IF  (NH.EQ.2.AND.KHEH.Er,.  i ) GO  TO  720 

* LATITUDE  LOOP  IN  ONE  HEMISPHERE, 

* IHEm  COUNTS  ePOm  The  POLE  TO  The  EQUATOR. 

* IHGG  INDEXES  The  RO^S  in  the  GAUSSIAN  GRIDS  STORED  IN  CORE. 

CO  700  IhEms1 , ILATH 
IHGGsIHEH 


I 


l«t 


r 


IF  (NH.ro.  I .AND.t'HEM.EC.1 ) IHGGs(ILATHM-IHEM) 
IF(Nh.EO.I.Ano.khem.EG.O)  IhGGs(IL4Th*1-IMEH)  + ilATh 
SUU  SIA(IHEM) 

CBAI=-CaA(IHEM) 

IF(NH.EQ.l)  C0AI=C8A (IHEH) 


* COMPUTE  AI_P,DAlP  AND  REORDER  ROWS  IF  GRIDS  ARE  HEMISPHERIC. 


CALL  ALPNU2(ALP,LALP,LM,C8AI,EPST) 

CALL  ALPDR2(DALP,ALP»LAlP,LM,EPSI) 

IF (KHEM.NE.O)  CALL  ALPAS2C  AL P , L ALP , LM , kRk S ) 
IF(Fhem.NE.O)  CALL  »LPaS2(DALP,LALP,U1»«rKS) 


* COMPUTE  GRID  P 0 I N T V A L L'  F S FROM  SPECIAL  C"EFF. 

CALL  MhEXPK(PG,CG,TG,ESG#UG,VG,rSDLG,PSDPG,PRF3SG#ILH,ILM, 

1 P,C,T,ES,U,v,PS,t.A,LA»,LRS,LPA,LRU,LRV,LM,ILEV,LtVS, 

2 ilg,«hem# alp,dalp,lalp,hrksi 

CO  «20  IK=|,ILG 

«2f)  PRESSG(IK)sEXP(PRESSG(Ik)+PSMNR2) 

* calculate  dynamic  parts  of  rhs. 

CALL  ST0APJ(AMBCPG#TG, AMeDA,STAMS,STAIS, 

1 ILM,  ILEV,  ILEYP,  lLG,N(jOS,WET,EXTRAP) 

CALL  VRTIGH(PUTG#PVTG#TUTG# TVTr,EG»SCSG#PEETr,0»'EGAG» 

1 PG#CG»  tg,lg» vg,psdlg»psdpg» ILM, ilg» ilev,leys, 

2 AM60PG,Af'PCA,TMEAN,S,SH,SF,SHF,DS,r>EL,SlAl,BETA, 

3 SUSG , S VSG,ESG#ESTG,L TBS, PCPSHD, AVERT) 

CALL  ENLAT(T0TK,EG,PRFSSG,ILG,ILEV,*8CS(IHEM),KHEM) 

* wet  CONVECTIVE  ADJUSTMENT  AN'C  calculation  OF  pretip. 

IJ«(lHGG-t)*ILGt*l 
IF (.N8T.WET)  GO  TO  300 

CALL  PCPADJ  (PCPPAK(M)  ,STRPAK  (I  J),  I LG  1 , E SG  , TG , Ot'EG  A G , PPTSSG , IL  M , 

* TMEAN,SF,STAWS, ILEV ,LEVS,LTRS,NUPS .NSLPS.KOUNT.CFLI 

PCPPAK(IJ+ILG1)=PCPFAK(IJ) 

STBPAK(IJtILGl)sSTBFAK (IJ) 

* PHYSICAL  EFFECTS  IF  REQUESTED. 

300  IF(KDR)  CALL  SFCR  AG  (PL  TO  , P VTG  , L G , VG  , TG  , THE  AN  , DRP  AH.  ( I J ) , IL*' , I LE  V , 
*ILG,GRAV,A,PGAS,DS,SIAI) 

IF(KWT.AND.KCV)  CALL  SF aFL X ( TG , ESC , UG , VG , TML AN , I LM , ILG , ILE V , 
*LEVS,DT>SIaI,SEAC8n,RG0cP,SH|WTPak(IJ),CVPAK(IJ)) 

CALL  VEMFLX(PUTG,PVTG,LG»VG#RK,DS,ILM,ILEV»ILG) 

* CONVERT  grid  POINT  VALUFS  rack  TO  SPECIAL  COEFF, 
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call  MHANlW(PTfCTfPEET,$DS,TPUH,EST,fcSDUM,PRESS,LA, 

1 pltg»pvtg,tutg,tvtg,peetg,sdsg,eg,tg,susg,svsg, 

2 ESTG,ESG,PPESSG,ILH,ILM,LRS,LRA,LM, 

3 ALP,DALP,LALP,WPKS,W(IHEM),WOcS(IHEM),IlG,KHEM,ILEV,LEVS) 

* ADD  DELSQ(KE)  TO  DIVERGENCE  TENDENCY. 

call  delekcct,la,lps,ln,eg,ilh,ilev,alp,dalp,lalp,khem, 

1 IR,  ILG,  U0CS(IHEH),WRKS) 

700  CONTINUE 
720  CONTINUE 

* SECTION  0 - END  OF  LATITUDE  LOOP. 

* RESTORE  RELATIVE  VOPTICITY,  WRITE  OUT  UNSTABLE  POINTS. 

DO  740  L=1 f ILEV 
N=(L-1)*LA+?-Ksyp 
740  P(N)sP2(L) 

IF (NTEST.NE.O)  WRITE (6,6040)  MJPS,NSUPS 

* RESTORE  CONVECTIVELY  fOPRtCTED  T,ES  FROM  TdLM.ESDUM. 

CALL  SETLCT,TDLM,LA,ILEVP) 

IF (WET)  CALL  SETL(ES,ESDUH,LA,LEVS) 

* CALCULATE  NEW  PEE  EROH  THE  NEW  TE"PEPaTuRES . 

CALL  BPFT(PEE,T,PS,FHIS,LA,LRS,LP,ILEV,TMEAN,RGAS,SF) 

* IF  FWD  STEP.  SET  PRFVIOUS  VALUES  TO  CURRENT  V*LUES. 
IF(IFDIFF.EQ.I)  CALL  SETOLD 

1 (PN,CM,PEE^,ESH,PSH,P,C,PEE.LS,PS,LA,ILEV,LEVS) 

* ADD  LINEAR  Terms  to  ct»  peet. 

CALL  LNER(CT,PEET,SCS,CM,PEE'',LA,LPS,1.M,ILEV,CT,RGAS,SF) 

* SECTION  5 - OUTPUT  SECTION. 

* CALCULATE  ENERGY  DIAGNOSTICS  IF  REQUESTED. 

800  IF(NOgR.GT.O.OR.IEPR.GT.O,OP.DIVch.gT.O.)  call  ENOUT 

1 (P,C,T»U*rS.PHIS»PRESS.TMEAK,TMFAN,sF,Ds, 

2 tctk,ir,ilev,khem,etots,ltot,nogr,iepr,civcf  ) 

* PRINT  COEFF  *No/OR  M4PS  EVERY  IPR  STEPS  IF  REQUESTED. 

CALL  POUT(P,C,T,PHI,PRESS,PUIS,ES,LA,LrS#I-RA,LP,ILEV,LEVS, 
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PEE,PS,PEEMN,PSMN,TMEAN,mAN,RGAS,IPR,LC,KSYM, 

GLL,ILGl,ILATH,C0A,KHEM»ALP,EP3l,LALP,WRKS,WRKL) 

* SAVE  FORECAST  «N  FILE  NF2  IF  REQUESTED. 

CALL  SAVPRG(NF2,PHI,U,V,ES,PHIS,PS,PEE,TMEAN,PEEMN,PSMN, 

1 rgas,la,law,lrs,lra,lRU,lRv*lm*ilev»lEv3,ksym, 

2 KSTART,KTOTAL»KOUKTtIPRG,GLl«GLL# 

3 ilgi,ilath,coa,khem,alp,epsi,lalp,wrks,wrkl) 

* SAVE  PRECIP  ON  riLE  NFPCP  EVERY  IPCP  STEPS  IF  REQUESTED. 

call  savpcp(pcppak,stbpak,ilgi,ilath#khem,nppcm# 

I KOUNT.K ST  ART, IPCP, NFPCP, NPPCP,GLL#WRKS) 

* SECTION  6 - PERFORM  ONE  IMPLICIT  TIMESTEP. 

IF (KOUNT.GE.KTOTAL)  RETURN 

IF(KOUNT.LE.KSTAPT+l)  CALL  ABCIKDT,  A,  ILEV,  IR) 

CALL  RHSSI (PEE8AR,PEET,SDS,LA,LRS,LM,ILEV,SF,DT) 

* GFT  NEW  PS,P,C,PFE.  COMPUTE  NEW  T. 

call  newpscps,psm,peet,peebap,la,lrs,lm,ilev,ambda,sf,avert, 

1 RGAS,PT,FPS,IFDIFF) 

call  NEWP  (P,pm,PT,LA,LRA,LM,ILEV,DT,FP,IFDIFF) 

CALL  NEWC(C,CM/CT,PEEPAR,LA,LRS,LM,ILEV,ASQ, 

1 0IFU$D,DT,FC,IFDIFF,KHEM) 

CALL  NEWBP(PEE,PEEM,PEEBAP,LA,LRS,LM,ILEV,FPEE,IFDIFF) 

IF(WET)  CALL  NEWES(ES,ESM,EST,LA,LRS,LN,LEVS,ASQ, 

1 DIFUSS, DT, rs, IFDIFF.KHEM) 

CALL  TFBP(T,PEE,PS,PHIS,LA,LRS,LM,ILEV,TMEAN,RGAS,SF,EXTRAP) 

DTsOEET 

IFDIFFsO 

KOUN  T aKOUNT  + 1 

GO  TO  200 

*005  F0RMATC1H1//32H  P.E.  SPECTRAL  MODEL  - VERSION 
6010  F0RMT(7H0  SP1mW,15I5) 

6015  F0PMAT(33HOLRS,LRA,LRU,LRV,LALP,LM,LA,LAW  =,815) 

6012  F0RMAT(7H0  SPImw,  1P10E12.3) 

6020  FORWATU2H0END  OF  STEP, 15, 6H  HP=,F«.2,6H  TIME,F8.2) 

6040  F ORM A T ( i i,45X,'MUPS  = ',15,'  NSUPS  = ',15) 

end 
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SUBR  OUT  I NL  STBADJ(AMBnPG,TG,AMBDA,STAMS,STAIS,lLM,ILEV,ILEVP, 
l ILONG, NUPS, WET, EXTRAP) 

* THIS  SUBROUTINE  IS  TO  BE  CALLED  BEFORE  VERTIG  IN  THE 

* DRY  MULTILEVEL  SPECTRAL  MODEL. 

* COMPUTE  PRIMED  STATIC  STABILITIES  IN  AMBDPG  AND 

* CORRECT  THE  VERTICAL  TEMPERATURE  PROFILES  IN  TG 

* FOR  ILONG  POINTS  ABOUT  ONE  GAUSSIAN  LATITUDE  CIRCLE. 

DIMENSION  AMBDPGdLM#  n#TG(ILM.  1) 

DIMENSION  STAMSCILEVP, 1),STAIS(ILFVP,  1) 

DIMENSION  AM8DA(U 

LOGICAL  WET 

ILEVMsILF.V-1 

CO  300  JH  = t,  ILEV 
I H 1 = JH 
IH2  = JH  ♦ 1 
CO  300  IKsl, ILONG 

* CALCULATION  OF  PRIME  STATIC  STABILITY 

AMBDPGCIK,JH)sO.O 
CO  300  IHslHl , IH2 

AMflCPG(IK, JH)=AMBOPG(IK, JH)+STAMS(IH, JH)*TG(IK, IH) 

300  CONTINUE 

IF(WET)  return 

* DRY  CONVECTIVE  ADJUSTMENT 


DO  tOO  IK=1, ILONG 
DO  30  JH  s l,  ILEV 

* CALCULATION  OF  TOTAL  STATIC  STABILITY  TAMBDA 
TAMBDA  s AMBDPG(IK,JH)  + AMBDACJH) 

IFCTAMBDA.GE.O.)  GO  TO  30 

* OAMBDA  IS  THE  STABILITY  CORRECTION  ADDED  TO  AMBdPG 
dambda*-Tamrdai*i  .0001 

DAHRDAsDAMBDAflO. 

AMBCPGCIK, JH)« AMBDPG (IK, JH)+D AMRO  A 

* CALCULATION  OF  THE  ADJUSTED  TEMPERATURES 
DO  20  IH*1 , ILEV 

20  TG(IK,IH)sTG(IK,IH)+DAMRDA*STAlS(JH,lH) 
TG(IK,ILEVP)*TG(IK,ILEV)*EXTRAP 
NUPSsNUPS+1 
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SUBROUTINE  STMCAl  ( ST  AM  AT , ST  A IN V , 3 , SH , $F , SHF , RG OCR , RG AS , GR A V , 
1 GA“MA,ILEV,ILEVP, EXTRAP) 


* CALCULATE  the  DRY  CONVECTIVE  ADJUSTMENT  MATRIX  "STAMAT"  and 

* ITS  INVERSE  "STAINV".  TO  INSURE  CONSERVATIVE  ENERGY 

* REDISTRIBUTION,  THE  RIGHT  HAND  COLUMN  (STAMAT (I, ILEV+J ) ) IS 

* FILLED  WITH  AN  INTEGRATING  VECTOR  WHICH  DEFINES  THE  ILEV*1 

* ELEMENT  OF  AMBPA  AS  A CONSTANT  WHICH  DEPENDS  ONLY  UPON  THE 

* TOTAL  POTENTIAL  ENERGY  IN  THE  VERTICAL 

DIMENSION  S(1),SH(1),SF(1),DEL(1) 

DIMENSION  STAMAT£lLEVP,t),STAlNV(lLEVP,n,SHF(l) 

ILEVM  s ILEV-1 

EXTRAp»C1,/5(ILEV))a*CRGAS*GAMMA/GRaV) 

CPePG AS/RGOCP 
DO  JO  J s l,  ILEVP 
DO  10  I s 1,  ILEVP 
10  STAMATCI/J)  = 0, 

DO  1 1*1, ILEVM 

STAMAT(I,n  = (PG0CP*0.5  + l ,/SF  ( I) ) /SH  ( I ) 

1 STAMAT(I+l,I)s(RG0CP*0.5-i./5F(I))/SH(I) 

STAMATCILEV, ILEV)3fRG0CP-RGAS*GAMHA/GRAV) 

DO  l I s 2,  ILEVM 

2 STAMAT(I,ILEVP)sS(I+l)-S(I-l) 

STAMAT(l,UEVP)sS(2)-S(l) 

STAMAT(ILEV,ILEVP)sl.-S(ILEVM) 

STAMAT(ILEVP,ILEVP)sl.-S(ILEV) 

CO  3 I«l, ILEVP 

3 STAMAT (I, ILEVP) sn,5*STAMAT( I, ILEVP )*CP 
CALL  MTXINV(STAINV,STAHAT, ILEVP) 

RETLRN 

END 
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SUBROUTINE  STp6(Nri,NF12*NF2,PR,LV#SlG*NK,GZ,T,U*V,ES,LEVS,LGG* 

1 ilg,nlat,nsteps,  MAPS,  MPSP,MPGZ,  MPT,  MPW,MPWSP,MPES, 

2 IN,  JU,LL,MM,NPSP,NPGZ,NPT,NPW^PES) 

* CONVERTS  NK  LEVELS  of  FORECAST  GAUSSIAN  GRIDS  TO  LV  PRESSURE  LEV 

* INPUT  UNITS  GZ,GZSs(M/SEC)**2,  LNSP=(MB). 

* T= (PEG  K),  U,Vs(M/SEC)/(EARTH  RADIUS) 

* GZ  IS  A WORK  FIEIC  TOR  NK  + t GRID  FIELDS  OF  FORECAST  PHICSIGMA) 

* AND  LV  GRID  FIELDS  OF  FORECAST  PHI(PRES). 

* T IS  FOR  LV  LEVELS  *P  TEMPERATURE. 

* U,V  ARE  FOR  WINOS.  THEY  CAN  BE  EQUlVALENCED  TO  GZ  AND  T. 

* PR  CONTAINS  THE  PRESSURE  LEVELS  IN  MILLIBARS. 

* SIG  CONTAINS  THE  SICMA  LEVELS. 

* mPSP,mPgZ,mpt,MPW,“F*SP,mpeS  ARE  map  CONTROLS  FOP 

* MSL  PR.GZ*TEMP,<L#V),  wind  speed*  dew  point  depression. 

* IF  MAPS=0  CONTROL  cards  were  not  read.  NO  MAPs  are  produced. 

DIMENSION  GZ(LGG,l),T(LGG,l),U(LGG,n,V(LGG,l),ES(LGG,t) 

DIMENSION  pR(LV),SIG(* K) 

dimension  MPGZ(n,MPT(n,uRw(i),MPwsP(n.MPEsci) 

* SCM  WORK  FIELDS. 

PARAMETER  SILVsis, jLf  Van, $LV  = 10,1 ILTs52,$ILGs6«,JILTHs26,SIRsZO 
PARAMETER  IILp1=JILV+1 
PARAMETER  SLAWailLT*(TlLG+l) 

DIMENSION  PPL  CJLV),F(TlLP1),GCJlLpl)*SG(SlLPt)#SGE(SILPl) 
dimension  wrksuso) 

* LCM  WORK  riELCS, 

COMMON/LCm1/PS(JLaw) ,pGG (SLAW) ,GGP (SLAW), WRKLC 130) 

LOGICAL  OK 

* SET  CONSTANTS. 

RGOCPsS , /7 . 

RGAS=287, 

GRAV  a R. 8061b 
ERAC=6.371F+6 
1LG1  = ILGM 
NSGLsNK+l 

* SET  SG  TP  LOG ( SIGM  A ) *ND  PR  TO  LOG (PRESSURE ) . 

* SGE  IS  LPG(SIGMA)  ON  THE  F.V£N  LEVELS. 
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DO  15  Nsl,NK 

15  SG(N)sALOG(SIG(N)) 

$G(NSGL)*0. 

DO  lb  Nsl.NK 

16  SGE(S)a,5*(SG(N)+SG(N+i)) 

DO  17  lst,LV 

17  PRLCUSAIOGCPPCL)) 

* READ  INITIAL  LMSF.PRES.)  FROM  NF  l • 

ID  s o 
rewind  NF l 

CALL  RSGGP(PGG,ILG1,NLAT,NF1,IC,<IHLNSP,  l,OK,GGP,WRKS) 

IF  (.NOT, OK)  RETURN 

* READ  INITIAL  PRESSURE  LEVELS  OF  GZ  FROM  NF  1 2 . PUT  INTO  V. 

REwIND  NF 1 2 
ID  s 0 

DO  251  L=1,LV 

CALL  RSGGP  ( V ( 1 ,L ) , ILG  J ,NLAT,NFl  2,  ID,  OH  GZ,L,0K,GGP,  WRKf?) 
IF  ( .NOT, OK)  RETURN 
251  CONTINUE 


* READ  MOUNTAINS  AND  FORECAST  OF  LNSP.PhI  FROM  FILE  NF1. 

305  IDsNSTEPS 

rewind  NF  1 

CALL  RSGGP(GZ(1,NSGL1*ILG1,NLAT,NF1 , 0,a«  GZS,  1 ,CK,GGP,w°KS) 

CALL  RSGGP(PS, ILG1 ,KLAT,NF1 , ID , UHLN$P , 1 , OK , GGP  , WRkS ) 

DO  310  Na  l , NK 

CALL  RSGGPCGZ(l#N),ILGl,NLAT,NFi,ID,UM  GZ ,N , OK  # GGP , WRk  S ) 
IF(.NOT.OK)  GO  TO  505 
310  CONTINUE 

* INTERPOLATE  FROM  S I G m A LEVELS  IN  SG  T 0 PRESSURE  LEVELS  in  PR. 

* The  CALCULATIONS  a«F  done  in  place  FOR  gZ#  TemPeRATuPeS  are  in  T 

* initial  PRESSURE  LEVELS  of  GZ  ARE  IN  V. 

GLAPSE  s 6.5F-3/GRAV 
EXTRApsl ,0 
K I NC  s 1 

CALL  SGTPRE (GZ,T,GZ,PS,LGG,LGG,PRL#LVfSG,F#G,NSGL# GLAPSE, EXTRAP, 

1 K I NB , V , PGG ) 


• M»P  GZ  IF  REGUESTEC  AND  SAVE  ON  NF2  WITH  PACKING  BFNSITY  NPGZ, 

00  <110  L=1,LV 
IF(MapS.NE.O)  CALL  FC0NW2 

1 CGZ(l,L),<J.O, l./9P.06l6,ILGl,NLAT,IW,Jw,LL,MM,MPGZ(L)) 
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CALL  WSGGP(GZ(1,L),ILG1,NLAT,NF2,ID,4H  GZ,L,NPGZ,GGP,WRKS) 

410  CONTINUE 

* T actually  contains  -rgas*t,  CONVERT  to  deg  k. 

* MAP  T IF  REQUESTED  AND  SAVE  ON  NF2  WITH  PACKING  DENSITY  NPT. 

DO  420  L=1  #LV 
DO  415  1=1, LGG 

415  T(I,L)=T(I,L)*(-1./RGAS) 

IF(MAPS.NE.O)  CALL  FC0NW2 

1 (T(1,L),5.,1.,ILG1,NLAT,IW,JW,LL,MM,mPT(L)) 

CALL  wSGGPC  T(1,L),ILG1,NLAT,NF2,ID,4H  T,L,NPT  ,GGP,WRKS) 

420  CONTINUE 

* COMPUTE  NSL  PRESSURE  (USING  THE  FOLLOWING  ASSUMPTIONS).., 

* A)  ,b* (DRY  LAPSE  PATH)  FROM  LOWEST  TEMPERATURE  Tfl  1000  He, 

* B)  msl  TEMPERATURE  EQUALS  iooomp  temperature. 

* MAP  IF  REQUESTED  ant  SAVE  ON  NF2  WITH  PACKING  DENSITY  NPSP. 

CO  440  1=1, LGG 

T100O=T(I,LV)*(l000./PF(LV))**(.6*RG0CP) 

GZ1000SGZ(I,LV)..5*RGAS*(T1000+T(I,LV))*ALOG(1000./PR(LV)) 

GGP(I)=1000.*EXPCGZ1000/(RGAS*T1000)) 

440  CONTINUE 

IF(MAPS.NE.O)  CALL  f c " N w 2 

t (GGP,5.,l.,lLGl,NLAT,lw,JW,LL,MMfMPSP) 

CALL  WSGGP(  GGP  ,ILG1,NLAT,NF2,ID,4HSFPR,1,NPSP,GGP,WRKS) 

* read  forecast  GRIDS  of  u,v  from  file  nfi, 

505  IDaNSTEPS 

CO  510  N=1,NK 

CALL  RSGGP(  U(1,N),ILG1 ,NLAT,NF1,ID,«H  U,N,OK,GGP,WRKS) 
IF(.NOT.OK)  GO  T"  e C 5 

CALL  RSGGP ( V(1,N),ILG1,NLAT,NF1,ID,4H  V,N,0K,GGP,WRKS) 
IF(.NOT.OK)  GO  TO  605 
510  CONTINUE 

* INTERPOLATE  FROM  SIGMa  LEVELS  IN  SG  TO  PRESSURE  LEVELS  IN  PR. 

GLAPSEsO. 

EXTRAPso, 

KIND=Q 

CALL  SGTPRE (U, DUMM Y, U, PS, LGG, LGG, PRL,LV,SG,F,G,NK,GL APSE, EXTRAP, 
l KIND, DUMMY, DUMMY) 

CALL  SGTPRE(V,DUMny,V,PS,LGG,LC-G,PRL,LV,SG,F,G,NK,GLAPSE,EXTRAP, 
1 KIND, DUMMY, DUMMY) 

* map  u,v  if  requested  and  save  on  nf2  with  packing  density  npw, 

DO  520  L«1#LV 
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IF(MAPS.NE.O)  CALL  FCCNW2 

1 CU(1,L),  tO.,E*AC,IlGi,NLAT, I"* J"»LL»mm,HPU(L)) 

4 CALL  *SGGP(  U(1,L)»ILG1,NLAT,NF2iID,«H  U,L,NPt*  ,GGP,*RKS) 

IF  (MAPS.NE.O)  CALL  FCPN*2 

l (V(1,L) , in.,E«AD, I LG  1, NL AT, I w, jw,LL,“H, hp w(L)) 

CALL  r.SGGP(  vn,L),ILGl,NLAT,NF2#ID,«H  V,L,NP*  ,GGP,*RKS) 
520  CONTINUE 

* WING  SPEED  IS  TAPPET  IF  REOUESTEO. 

CP  530  L=1,LV 

IF  (PPwSP(L)  ,EQ,0)  G 3 T3  530 
TP  526  1=1, LGG 

526  GGP(I)=SQRT(U(I,L)**?+V(I,L)**2) 

IF c^aos.SE.O)  CALL  FCPNW2 

1 (GGP, 10.,ERAC,ILG1,NLAT,IW,Jm,LL,MM,mpwSP(L)) 

530  C 3NT I NUE 


* READ  FORECAST  GRICS  OF  ES  FRO-'1  file  NF1. 

605  IDs ESTEPS 

IF (LEVS, EG. 0)  RETURN 
C?  610  Ksl,LEVS 
Ns (NK-LEVS  ) ♦ K 

CALL  RSGGP(  U(l,N),ILGl,NLAT,EFi,iD,UH  E S , h , 0* , GGP , "P* S ) 
IF(.NflT.OK)  return 

fcjo  continue 

* FILL  I*>  HISSING  levels  9F  ES, 

LDUF*NK-LEVS 
IE (LCUM.EQ.05  GO  TP  6 1 P 
CP  t 15  Ksl.LDU* 

C?  615  1=1, LGG 
615  E5(I,k)bES(I,LDLP*1 J 

* INTERPOLATE  FROM  S I G M A LEVELS  IN  SGE  TO  PRESSURE  LEVELS  I‘  PR. 

618  GLAFSE=0, 

ExTRAPso. 

KlNCsO 

CALL  SGTPRE (ES,rLH^y,FS,PS,LGG,LGG,PRL,LV,SGE,E,G,NK,GLAPSE , 
l extrap, kind, dummy, duuuy) 

* Map  ES  IF  REGLFSTEC  and  Save  PN  NF2  P I T h Packing  DENSITY  NPES, 

C 3 620  L=1«LV 
IF(*’APS,NE.O)  call  fC*Na2 

1 (ES(1,L),5.0,  1.0,ILG1,NLAT,I*,Jw,LL,Uu,mPESCL)) 

CALL  -SGGP(ES(1,L),ILG1,NLaT,nF2,IC,um  E S , L , nPe S , GGP  , *RKS  ) 


I - 151 


I 


SUBROUTINE  TERP1  ( X , FX , F , G , Y , ACC , NN ) 

DIMENSION  F(NN),G(NN),Y(NN) 

* GIVEN  the  values  OF  A ‘"'MTJMC  FUNCTION  F AND  THE  VALUES  OF  ITS 

* DERIVATIVE  G AT  NN  POINTS  Y(l)  TO  Y(NN),  THIS  ROUTINE  FINDS  X 

* POINT  AT  WHICH  F ASSUMES  The  SPECIFIED  VALUE  FX. 

* N* TE  AT  INPUT  A FIRST  GUESS  SHOULD  BE  PROVIDED  FOR  X. 

* NOTE  "E  ASSUME  FX  LE  F(l) 

IF  CFX.LE.F(NN))  GO  TH  (|0 
IF  (FX.GT.F(i)  ) WRITE(6,600) 

* interpolation 

DC  10  N«  1 f NN 

IF  (FX.GT.F(N))  GO  TO  2o 
1(1  CONTINUE 

2 n FlsF(N-l) 

FO=F (N) 

GlaG(N-l) 

GOaG(N) 

V 1 a Y (H-l) 

Y ')  a Y ( N ) 

CYsYl-YO 
Aa  + F 1/PY 
Pe.FO/CY 

Cs(G0tGl)/DY**2  - 2.*(Fl-F0)/DY**3 
CDe(Yl*G0*Y0*G1-(A  + P)*fYUY0))/DY**2 

* NEwTON  FORMULA  ITERATES  lO"P 

30  Pax-YO 
G = X-Y  1 
RaC*X-CC 

EPaA#P4B*Q+P*G*R-FX 
IF  (ABS(ER).LT.ACC)  return 
DERaA*6+P*R*Q*R+C*P*C 
X a X -ER/DEP 
GO  TO  30 

<|0  IF  (FX.EO.F(NN))  GO  TP  fc0 

* EXTRAPOLATION 

FlsF(NN-l) 

FOaF (NN) 

G1=G (NN- 1 ) 

GOaG (NN) 

YlaY(NN-l) 


i 
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YOaY (NN) 

ROOT  = G0**2  - 2.*(Gfl-Gn*(FO..FX)/(Y0-Yl) 


* IF  ROOT  GE  0 USE  GUAORATIC  EXTRAPOLATION 

* IF  ROOT  LT  0 USE  LINEAR  FORMULA 

IF  (ROOT.GE.O.)  GO  TO  50 

X=YOt(FX-FO)/GO 

RETURN 

50  ROOTsSQRT (ROOT ) 

XSYO-(YO-Yn*CGO*ROOT)/(GO-Gi ) 

RETURN 

60  X*Y (NN) 

RETURN 

600  FORMAT (I2H1TERP1  ERPOR) 

END 


SUBROUTINE  Tf RP2  (FX,GX,X,F,G,Y,NN,RUaPSE) 

DIMENSION  F(NN),G(NN),Y(NN) 

* GIVEN  A FUNCTION  F AND  ITS  FIRST  DERIVATIVE  G AT  A SET  OF  NN 

* UNEVENLY  SPACED  POINTS  Y,  THIS  ROUTINE  CALCULATES  FX  ANC  GX, 

* THE  VALUES  OF  F AND  G AT  THE  SPECIFIED  POINT  X. 

* RLAPSE  IS  A LAPSE  RATE  USED  FOP  EXTRAPOLATING. 

* EXTRAPOLATION 

IF  (X.GT.Y(l))  GO  TO  10 
GX  = GQ1 

Fx  = F(l)  + (X-Ym)*G(l) 

RETURN 

10  IF  (X.LT.YCNN))  GO  TO  20 
GXsG(NN)+ (X-Y (NN) )*RLAPSE 
FXsF(NN)+,S*CX-Y(NN))*(GX+G(NN)) 

return 

* INTERPOLATION 

20  DO  30  N=2,NN 

IF  (X.LT.Y(N))  GO  TO  40 
30  CONTINUE 

«0  FAsF(N-l) 

FBsF (N) 

GAbG (N-l ) 

GPsG(N) 

A=Y (N-l) 

P=Y(N) 

* given  fa#fb*ga  and  Ge  The  values  oe  f and  g at  points  a and  r 

* Respectively,  this  cubic  interpolation  algbpithm  gives  fx  anc 

* Gx  the  values  OF  the  functions  F and  G AT  The  INTERMEDIATE  P 0 1 

D = B“  A 

EBX“ , 5* ( A+B ) 

Rs,125*D*D-.5*E*F 

FMos,5*(FA+FB) 

FM 1 s (FB«F  A ) /D 
FM2s(GB-GA)/n 
FM3s(GB+GA-FMl.FMi)/(D*D) 

FL2sFM2t2,*E*FM3 

FLl«FMltE*FL2 

FLOsFMOfE*FHl 

FXsFL0-R*FL2 

GXsFL1-2.*R*FM3 

RETURN 
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SUBROUTINE  TfRP2E (fX,CX*X#F#G, Y,NN, EXTRaP,GL APSe.FI  # XI) 

* GIVEN  A FUNCTION  F and  ITS  first  derivative  g at  a set  of  nn 

* unevenly  spacfd  points  Y,  THIS  ROUTINE  CALCULATES  fx  and  gx, 

* THE  VALUES  OF  F AND  G AT  THE  SPECIFIED  POINT  X. 

* EXTRAPs  1 , FOR  HEIGHTS  AND  TEMP  * 0.  FOR  WINDS. 

* RL APSE  IS  A LAPSF  RATE  USED  FOR  EXTRAPOLATING, 

DIMENSION  F (NN)#G(NN),Y(NN) 

* EXTRAPOLATION  ABOVE  TOP  LEVEL. 

IF  (X.GT.Y(l)J  GO  TO  10 
G X = G ( 1 ) 

FXaF (1)+(X«Y(1))*G(1) 

RETURN 

* EXTRAPOLATION  BELOW  SIGt'Asl, 

10  IF  (X.LT.Y(NN))  GO  TO  20 
TLAPSE  » ,1R2857*EXTRAP 
GX  = G(NN)*(1,  + TL APSE* (X-Y (NN ) ) ) 

FX  s FINN)  ♦ ,5*fX-Y(NN))*(GX*r,CNN))*CXTRAP 

IFCEXTRAP.LE.O.)  return 

IF(XI-Y(NN).LT..001)  RETURN 

TMI  3 CF(NN)-FI)/XI 

FX  = FINN)  - TM I * X 

GX  s G(NN)  ♦ GLAPSE*(F(NN)-FI) 

RETURN 

* interpolation 

20  CO  30  N s 2 » N N 

IF  (X.LT.Y(N))  GO  TO  00 
30  CONTINUE 

UO  FAsF(N-l) 

F 8 s F ( n ) 

GAsG(N-l) 

GBsG(N) 

A=Y(N-1) 

EsY (N) 

* given  fa.fb.ga  anc  gb  the  values  of  f and  g at  points  a and  b 

* respectively,  this  cubic  interpolation  algorithm  gives  fx  and 

* Gx  the  values  of  the  functions  f and  g at  the  intermediate  poi 


DsB-A 

ESX-,5*(A+B) 

R=.125*D*D-.5*E*E 
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FM0s,5*(FA+FB) 

FM1*(FB-FA)/D 

FH2s(GB-GA)/D 

FM3s(GB+GA-FMl-FHn/(n*C) 

FL2sFH2+2,*E*FM3 

FLlsFMl*l*FL2 

FL0sF-'0  + E*FM1 

FX=FL0-R*FL2 

GX=FU-2.*R*FM3 

RETtRM 

END 
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SUBROUTINE  TFBP CT ,PEP»PS,PH IS ,LA»L«S»lM,Il.EV, THf an,RG AS, SF# EXTRAP) 

* calculates  T FROM  PEE, PS, phis, 

* IF  MODEL  IS  HEMISPHERIC  T, PEE, PS, PHIS  ARE  SYMMETRIC. 

* EACH  LEVEL  IS  DIMENSIONED  CLRS,LM). 

* EACH  LEVEL  IS  SEPARATED  E»Y  LA  COMPLEX  WORDS. 

* T AND  PEE  MAY  BE  EQUIVALENCES , 

COMFLEX  T(LA,1),PEE(LA,1),PS(1),PHIS{1) 

DIMENSION  TMEANC1 ),5F(t) 

COMPLEX  PH  I S 1 , PSURF 

PHISlsPHlSU) 

PHisn  ) = co.  0,0.0) 

ILEVMsILEV-1 

ILEVPsILEV+1 

CTs2,/((1,*EXTRAP)*FGAS*SF CILEV)) 

DO  30  m3i,lm 
H«=(m-1)*LRS 
DO  30  N=1,LRS 
ILsHR+N 

PSURFaRGAS*TMEANCILEVP)*PS(IL)+PHISCIL) 

T(IL,ILEV)SCT*(PEE(IL,ILEV)-PSLRF+RGAS*PS(ILI* 

H the  AN  (ILF.  VP) -THE  AN  (I  LE  y)  ) ) 

TCIL,ILEVP)sEXTRAP*T(IL,ILEV) 

DO  50  IHS l , ILEVM 
IHHILEV-IH 

50  T(IL,IHl)a-T(IL,lHI  + l)-2.*(PEE(IL,IHUl)-PEE(IL,lHl)-RGAS* 
*(TMEAN(IH1+1)«TMEAN(IH1))*PS(IL))/(RGAS*SF(IH1)) 

30  CONTINUE 

PHismaPHisi 

RETURN 

END 
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SUBROUTINE  TFGZ(T,PHI,PhIS#LAiLRS,LM,IIEV,SFiRGAS,3,GRAV#GAHMA) 


* CALCULATE  TEMPERATURES  (T)  AT  ODD  LEVELS  FROM  GEOPOTENT JALS 

* AT  ODD  LEVELS;  ASSUME  SURFACE  TEMPERATURE  FROM  A LAPSE 

* RATE  OF  "GAMMA" 

* IT  MODEL  IS  HEMISPHERIC  T.PHI  ARE  SYMMETRIC. 

* EACH  LEVEL  IS  DIMENSIONED  (LRS.LM). 

* EACH  LEVEL  IS  SEPARATED  BY  LA  COMPLEX  MORDS. 

* T AND  PHI  CAN  PE  EOLIVALENCEC, 

COMPLEX  T(LA, t),PhI(LA#l ), PHIS  Cl) 

DIMENSION  SFCD.SU) 

ILEVMsILEV-1 
ILEVP  » ILE V ♦ l 

EXTRAPsi./S  CILEV)** (RGAS*GAMMA/GRAV) 

CONs-2./(PGASaSF(ILEV)*(1  ,+EXTRAP)) 

DO  1 I = 1,  LA 
1 PHICI,ILEVP)=PHIS(I) 

DO  20  Msl,LM 
MP=(M-l)*LRS 
DO  30  Nsl.LRS 
MNsrR+N 

T(mN/ILEV)sCPHJ(MN/ILEVP)"PHI(mN.ILEV))*CON 

T(MK,ILEVP)=EXTRAP*T(MN,ILEV) 

00  20  L=2»  ILEV 
L1=ILEVP-L 

20  T(MN,LI)s-TcMN,LUl)-2.A(PHI(MN,Ll  + l)-PHl(MN#L>))/(RGAS*SF(Ln) 
30  CONTINUE 

return 

END 
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SUBROUTINE  TMCAL  C Tr E AK , AMfiD A , S , SH , SF , RGOCP # ST A*9 , ILE V , ILE VP ) 

* SUBROUTINE  CALCULATES  HOP  I ZOtlT ALLY  AVERAGED  TEMPERATURES  AT 

* The  full  LFVELS  AND  also  the  horizontally  AVERAGED  STATIC  STABILI 

DIMENSION  TMEANCn»AMPDA(l),SCt),SR(n»SH(l),STAMS(ILEVP,l> 

InRITE  (6,6012)  (TMEAN(L)fLslf  ILEVP) 

* SET  AMBDA  TO  AVERAGE  STATIC  STABILITY  AT  HALF  LEVELS. 

DO  30  JHsl.ILEVP 
AMRCA(JH)  = 0. 

00  30  IH*1,ILEVP 

30  AMRCA(JH)  s AMBDA ( J H ) ♦ ST AMS ( IH , JH ) *TME AN ( IH ) 

HRITE(6,fc0l2)  (AMBDA(L),Lsl#lLEVP) 

RETURN 

6012  FORMAT (7Ho  TMCAL.1P10E12.3) 

END 


SUBROUTINE  T5IG  (RT  , G Z * SG , NN , TOLAPS  , SENTR  , c ON ) 

DIMENSION  RT(NN)»GZ(NN),5gCnN) 

* GIVEN  GEOPOTENTIALS,  GZ,  AT  A SET  OF  (UNEVENLY)  SPACED  POINTS, 

THIS  ROUTINE  COMPUTES  RTs-RGA$*TEMPERATURE  AT  THOSE  SAME  POINT 

* SG  MUST  CONTAIN  TNE  POINT  CO-ORDINATES. 

o BOUNDARY  CONDITIONS  SPECIFIED  BY  TOl>PS , SENTR , CON  (SEE  BELOfc). 

DO  10  N-2 , NN 

10  RT(N)s(GZ(N)-GZ(N-l))/(SG(N)-SG(N-l)) 

A sR  T ( 2 ) 

NNMsMJ-1 
CO  20  N s 2 , N N H 

2 0 RT  (N)s((SG(N+l)-SG(N))*RT (N)  + (SG(N)-SG(N»l))*RT (N  + 1 ) ) / 

1 (SG(N+1)-SG(N-1)) 

* BOUNDARIES 

PT(1)*SENTR*{ (3.*T0L*PS)*A-(l.+TOLAPS)*RT(2)) 
RT(NN)bC0N*RT(NN)+(1.-CON)*RT(NNM) 

RETURN 

ENO 
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SUBROUTINE  VEMFLX(PUTG,PVTG,UG,VG,RK,pS,IIM,ii.ev,IIONG) 

* CALCULATES  VERTICAL  EDDY  MOMENTUM  FLUX  EXCEPT  FOR  CONTRIBUTIONS 

* AT  THE  GROUND  (THE  SURFACE  DRAG  TERM) 

* FOR  ILONG  POINTS  ABOUT  ONE  GAUSSIAN  LATITUDE  CIRCLE, 

« EACH  ARRAY  HAS  ILEV  LEVELS,  MAX  VALUE  IS  15. 

DIMENSION  UG(lLM,n,VG<ILM,n,PUTG(ILM»l)»PVTG(ILM#i) 

DIMENSION  RKcn.nsm 
DIMENSION  TAUX  ( 15)  • TAL'V  C 15) 


ILEVM  s ILEV-1 
ILEVP  = ILEV+1 
TAUXin  « 0. 

TAUY(l)  s o. 

TAUX (ILEVP)  = 0. 

TAUY(ILEVP)  s o. 

CO  30  IKsJ, IL"NG 

DO  15  IH*1, ILEVM 
I HP  = I H ♦ 1 

TAUX(IHP)  s RK(IH)*(l!G(IK,IHP)  - IIG(IK#IHJ) 

TAUY(IHP)  = -RK(IH)a(VG(IK,IHP)-VG(IK#IH)) 

15  CONTINUE 

DO  20  Ih«1,ILEV 
IMP  s I H+ 1 

PUTG(IK.IH)  a PUTG(IK,IH)+  ( T AL Y ( I HP ) - T AU Y ( IH )) /DS ( IH  ) 
PVTG(IK,IH)  s PVTG(IK,IH)  4 (TAUX(IHP)  - T AUX ( IH) ) /DS ( I H ) 
20  CONTINUE 

30  continue 

RETURN 

END 


SUBROUTINE  VRTIGW(PLTG,PVTG,TUTG,TVTG,EG,SDSG,PEETG,OMEGAG, 

1 PG,CG,TG,UG,  VG,PSOLG,PSDPG,ILM,ILONg,ILEV,LEVS, 

2 AMBDPG, AKBDA,TmEAN,$,SH,SF,ShF,DS,CEl»SIAI,BETA, 

3 SUSG, SVSG,ESG,ESTG,L TBS, RCPSHO, AVERT) 

* calculates  dynamic  parts  of  rhs  of  spectral  model  equations 

* FOR  ILONG  POINTS  ABOUT  ONE  GAUSSIAN  LATITUDE  CIRCLE. 

* levels  in  this  subr  are  numbered  down  from  the  top 

* STARTING  WITH  SIGMA  s o.  every  SECOND  LEVEL  DOWN  FROM  HERE 

* TO  THE  SURFACE  IS  CALLED  AN  EVEN  LEVEL.  THE  OTHERS  ARE  ODD. 


k 


RE  AL  PUTG(ILM,  l)  ,PVTG(ILM,  n.TUTGCILM,  n,TVTG(lLH,  1) 

REAL  EG(lLM,l),SOSG(ILM,l),PEETG(ILM,l),0MEGAG(ILM,l) 

REAL  PG(ILM,1),CG(ILM,1),TG(ILM,1),UG(ILM,1),VG(ILM,1) 

REAL  SUSG(ILM,1),SVSG(ILM,1),ESG(ILM,1),ESTGCILM,1) 

REAL  PSDLGC 1 ) , PSDPG (1 ) , AM6DPG  ( I LM , 1 ) 

DIMENSION  AMBDACn,TMEANCl),SCn,SH(l),SFCn,DSCl) 

DIMENSION  RCPSHD(n,DELCl),SHF(n 

COMM ON /PAH AMS/  Ww,TW,A,aSG,GRAV,RGAS,RGOCP,RGOASQ,CPRES 

WORK  ARRAYS  FOR  this  SUBROUTINE.  MAX  LEVEL  IS  5 1 L V 

FARA«ETER  SIL Vs  16, $LEVso,IL V« 10, SlLT  = «52,JlLG  = 6R,SlLTHa26,SlFe20 

DIMENSION  CIGH(*ILV),UIGH(SILV),VIGH(SILV),SDH(SILV),DUSh(ULV), 
*DVSm(IILV),TgF(IILV),IJGhCIILV),Vgh(IILV),CGH(SILV)»SDDUS(IILV), 
*SDDVS(SlLV),VERTT(IiLV),VERTS(SlLV),DSSH(SlLv)»wA($iLV),w»»{TiLV) 
*,TGH($ILV),VEPTH($ILV) 

DATA  EPS/. 62197/ 

ILEVMsILEV-1 
ILEVPsIlEV+1 
RECCSQsl ,/(SIAI**2) 

DO  iu  IHsl,IlEVM 

WA(IH)  s (SH(IH)-S{IM))/(S(IH+1)-S(IH)) 

WB(IH)  s (S(IH+1)-SH(IH))/(S(IH+1)-S{IH)) 

1«  CONTINUE 

DO  900  IKsl, ILONG 

* VERT T s VERTICAL  COLUMN  OF  TEMP  AT  ODD  LEVELS. 

CO  16  IHsl.ILEVP 

16  VERTT(Ih)  s TG(IK,IH)  +TMEAN(IH) 

* (CIV,IJ,V)  BARSIGMA  AT  EVEN  LEVELS. 
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CIGH(IIEV)  = -Cr,(IK,lLEV)*DS(ILEV) 

LIGKILEV)  = -IG(IK,UEV)*DS(IIEV) 

VIGHCILLV)  s -VG(IK,ILEV)*OS(ILEV) 

D*  10  IHI  = 1,ILEVM 
IhsILEV-IHI 

CIGH(IH)  = CIG»*(IM*1)  • CG(IK,IH)*0S(IH) 
tlGh(IH)  = UIGP (IH*1 ) - UG(IK,ln)#DS(IH) 

10  VIGH(IH)  = VIGH(IHM)  - VG(IK,Ih)*DS(IH) 

* LAT  AND  LONG  DERIVATIVES  OF  LNSP.  AUCTION  Op  L^SP, 

PSDFOCsPSDPGtlKJmRECCSO 
PSDIPC=PS0LG(Ik)*RECC3C 
VMDPSsUIGH(1)*PSDL8C+VIGm(1)*PSDP8C 
DPSCTsCIGH ( 1 ) ♦ V li  D P S 


* SIGMAD'T  AT  FVEN  LEVELS. 

CO  20  Ins  1 » ILE VM 
SIGsl.-SH(IM) 

SCH(lH)«SIG*ClGR(n-CIGH(IH*l)  + 

1 C S I G*U IGH  c 1 )-LlGH(lH*n  J*PSOLPC  + 

2 (SIG*VIGt-n)-vlGH(lH+t))*PSDP8C 
20  CONTINUE 

SDHCIlEV)sAVERT*SDH  CILEVM) 

* P(U,V)/D(SIGPA)  AT  EVEN  LEVELS. 

CO  30  IH*1#IIEVP 

CLSt-(IH)  s (UG(IK,Ih  + l)  - UG(IK,Ih))/DEL(IH) 

30  DVSh(IH)  : (VG(lK,Ih  + n - VGCIK.Iwn/DELCIH) 

* ( C I V # U * V ) AVFPAGEC  TO  even  LF.VELS, 

CO  35  Ih  s 2 » I L E V 

LGH(lH-n  s UGClK,IH-n**BCl>--1  J ♦ LG(IK,IH)*UA(Im-1) 
VGH(Ih-I)  s VG(IK,IH-1)*ko(ih-1)  ♦ VG{Ik,IH)**A(Ih-1) 

35  CGH(lM.t)  s CG(lK,lh-l)*>.p(It--l)  ♦ CG(IK»Ih)*hA(Ih-1) 
UGh(ILEV)  s 0ETA*uG (I*,  ILEV) 

VGH(IlEV)  s BETA  *VG  C Ik  , ILEV  ) 

CGk ( I L E v 3 = 0ETA*CG(Ik#ILEV) 

* VERTICAL  POTION  aT  even  LEVELS. 

CO  3b  IHS1.ILEV 

CPC-  = SH(IH)*(LGH(II-)  *PSCL*IC  ♦ VGh(Ik)*PSDPOC) 
0*mEGAGCIK#  IH)  s O^G  ♦ ShCIH)*CPSDT  ♦ SDH(lh) 

36  CONTINUE 

* TEMPERATURE  log  AVE°AGEC  to  odd  LEVELS. 
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TT^TOTIOVHcl  AX  X iVu  J XiXi./  2 j.  I 3 ill 5 


0 8 37  IH*1»ILEV 

37  TGF(IH)bTG(IK,IH) 

* A N 0 T 8 EVEN  LEVELS 

CB  38  Ihs2,ILEV 

TGH(lM)a(SHF(lH)*TG(lK,IH)*SHF(IH-l)*TG(lK,lH*l))/ 

*(SHF(IH)*SiH(lH-l)) 

38  VERTH(IH)s(VERTT  CIM*SKr  (IH)+VERTT(1H*1)*SHF(IM.1  ))/ 
«(SHF(IHJ*SH(IH-t)) 

TGM(n  = (TG(lK,n*ALCG(S(2)/SH(l))  + TG(IK,2)*AL8G(SH(l)/S(l)))/ 

*SF  ( 1 ) 

VERTH(l)=(VE9TT(i)*AL3GcS(2)/SHci))+VERTT(2)*AL8G(SH(n/SCl)))/ 

*SF  ( 1 ) 

« SIGMAD87*D(IJ,V)/C(SIG,'A)  at  80D  LEVELS. 

08  «0  IH=2,ILEVM 

SCDLS(IH)  = (DELClH-n*SrH(IH)*DlJSH(lH)  ♦ SPH  ( iH-l ) *DUSH  ( IM- 1)* 
1 OEL(IH))/(DEL(IH)  + DEL(IH-l)) 

an  SDDVSCIH)  S (DEL(IH-l)*SOHtIH)*DVSM(lH)  ♦ SDH ( IH-l ) *0 VSH ( Ih- 1 ) * 
l DELdHjJ/CDELCIH)  ♦ CEL(IH-l)) 

SDOLS(l)  = S(n*SOH(l)ADUSH(l)/DS(l) 

SDOVS(l)  = S(l)*SDH(n*PVSH(l)/DS(l) 

SCDLS(ILEV)  = DEL(ILEV)*SPH(ILEVu)*DUSH(ILEVM)/r)SfILEV) 
SCDVS(ILEV)  = nEL(ILEV)*SOH(lLEV“)*OVSH(lLEVM)/DS(ILEV) 

* N8*  BEGIN  T"  C8MPLTL  The  RIGHT  HAND  SIDES. 

08  5 1 IHSUILEV 

PVTG (IK#lH)sPG(IK, IH)«VG(IK, IH)-SDDUS(IH) 

1 -TGF(IM*9G?ASQ*PSDLG(IK) 

PUTG(IK,Ih)sPG(IK,im*LG(IK,IH)+SDDVS(IH) 

1 ♦TGF(IH)*PG8aSQ*PSDPG(IK) 

51  C8NTINUE 

08  53  iHsl.ILEV 

TUTGdK,  IHJsTGH  (IH)*LGH(IH) 

53  TVTG(IK,Ih)sTGH(Ih)«VGH(IH) 

08  55  IhsI.ILEV 

SDSG (IK, IH)suG(Ik, IH) »PSDLeC+VG (Ik#IH)*PSDPCC 
55  EG(IK,IH)sLG(Ik,IH)*«2+VG(IK,IH)**2 

08  60  IHsI.ILEVH 
RG8CPTsRG8CP*VERTH(lHl 

PEETG(IK,IH)3-TGH(IH)«CGH(IH)-RG8cPT*(UGH(IH)*PS0L8C* 
*VGH(lH)*PS0P8C3-AMecPG(IK,lH)*SDH(lH)-RG8CR*TGH(lH)*DPS0T 
60  CONTINUE 

RG0CPT=RGOCP*VERTh(lLFV) 
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PEETGCIK,  ILEV)s-TGh(lLEV)i*CGH(ILEV)-RG0CPT*eET4i*SnSG(IK#ILEV) 
*-RG0CP*TGH(ILEV)*OPSDT-4VEPT*APBDPG(IK#ILEVM)*3oH(ILEVM) 

* MOISTURE  VARIABLES  CHITTED  IF  LEVSaO). 


IF(LEVS.EQ.O)  GP  TP  9QO 
On  61  IH*1,LEVS 

SUSG(IK,IH)  s ESG(IK,IH)*UGH(IH+LTBS) 

61  SVSG  ( IK  , IH)  s ESG  (IK,  IH)*VGH(I(-  + LTBS) 

OP  64  iHsl ,LEVS 
64  VERTS(IH)=ESG(IK,IH) 

call  DFDSQO(DSSH,VERTS,SH(LTBS+l),RCPSHD,LEVS) 

DO  70  IHsl, LEVS 

TO  «VtRTT(IH*LTBS)-ESG(IK#IHl 

= S0H(IH+LT8Sl/SH(IHtLTBS) 

+ (UIGh(n+LGH(lH+LTBS))*PSDLOC 
♦(VIGm(1)*VGh(Ih*LTBS))*PSDP0C  ♦ CIGH(l) 

s ESTGCIK, IH)* 

RGOCP* (VERTT (IM  + LTBS)-TO*TD/(EPS*HTVOCP(TO) ) ) 
= ESTGCIK, IH)  ♦ ESG(IK,IH)*CGH(IH+LTBS) 

- SOH(IH*LTRS)*DSShCIH) 


END 


ESTGCIK, IH) 

1 

2 

FSTG(IK,IH) 

1 

ESTGCIK, IH) 

1 

70  CONTINUE 
900  CONTINUE 
RETURN 
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SUBROUTINE  *E Tc ?N ( S T, RCPS^c, S, Sh, SF, DEI «*GOcP#ILEVm# LEVS) 

* COMPUTES  ST , THE  STABILIZATION  MATRIX  SUCH  THAT 

* TT  « STl*T(lf)*ER)  ♦ ST2«T(UPPER) 

* G A M « TT  ♦ST!*(TClP<fER)-T(lPPER)) 

* CT(LPPER)  sST«*(GAC-GAM) 

* CT(LCWER)  *ST5*rT (UPPER ) 

* C3HPUTES  RCPSHOi  THE  RECIPROCAL  PF  O(SH) 

CI^ENSie*.  ST(lLEVM,fc),RcPSHDm,S(l)»3H{l),Sr(l) 

* PARAMETERS  LSEC  °Y  FUNCTION  HTV3CP 


C0h^8^/wtcp/TIS#T2S»ai#pI,Ai»,Bi»#SLP 

• parameters  used  p*  function  dempnt#  spcmim#  oeit 

C8M-ftN/EPS/A,B#EPSl ,EP$2 

• paRa“ETERS  USED  BY  FUNCTION  GAMSAT 
COMVO^/GAMS/EPSSfCAP a 

* parameters  usfc  in  c'nacj 

COMMflN/AOJPCP/HC,MF,MM>4A,DEpTM,LHEiT,Hi»lAOJ,M8lFLY 
DIMENSION  CEL!!) 

* ILEVM  IS  JUST  TLEV-t.  LTfiS  IS  the  NU“BE«  8F  MISSING  -ET  LEVELS. 

LTBSs(IlEVH*1)-LEVS 

TMIRCal  ,/J. 

CO  10  I s 1 , ILEVM 
X 8 l./(SF(IJ  ♦ SF(IM)) 

sT(i,n  * **(SF(i*i)  ♦ 2.*srcm/3. 

ST (1,2)  * x*CSP(I)  * 2 , *SF ( I ♦ 1 ) ) /3 . 

ST  C I # 3 ) s 2,*X/RG?Cp 
ST(I,5)  * -DEL ( I ♦ 1 ) / DEL  ( I ) 

10  ST  ( I,b)s  (S(n/SH(IA1))**THIPC 

CO  20  I s 1 # ILEVm 

20  ST(l,4)Sl./(STCI/2)-STCl#3)*ST(I,';)*C5T(I,l)*STCI,3))) 

LEVS“bLEVS-1 
Of  30  I s 1 , L E V S“ 

30  RCPSHR ( I ) s 1,0  / (ShCI>LT°S+l)-S-(I+LTBSn 


RAUPsl.E+3 

GRAvsR, 9061o 

CEPTh  s i,/(RAU»*3RAV) 


I - 1 e 9 


CP*10Q<|,5 

CAPA*RGOCP 

718*273.16 

T2S*258,16 

AW*3.15213E*6/CP 

BW*2,38E+3/CP 

AlB2,ae0S3Et6/CP 

01*0, 167E+3/CP 

SLP«1,/(T1S-T2S) 

**21,656 
0*501 8 , 

EPS1*0,622 
EPS2*0  • 378 
EPSS*EPS1 
**=0.0 

IP(HM,LT,1.)  A**1./(6.*(1.~HM)*a2) 

petirn 

END 
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SUBROUTINE  W3GGPCGG#NLG»NUT,NF,ID,NAMF,N,NPACK,GGP,WRK$) 

* WRITES  ARRAY  GG(NLG#NL*T)  ONTO  SEQUENTIAL  FILE  NF 

* PRECEDED  BY  AN  IDENTIFYING  LABEL  OF  7 WORDS. 

* ID  a IDENTIFICATION  NUMBER  FOR  THE  RECORD. 

* name  & alphanumeric  label  for  the  fiblc. 

* N a NUMERIC  LABEL  FOR  THE  FIELD. 

* GGP , WRK$  ARE  WORK  fields  usfd  only  if  field  is  PACKED. 

* GGP  a N|.AT*((NLG-t  J/NPACK  + 2)  WORDS  IN  LCM. 

* WRK5  a NLG  WORDS  IN  SCM. 

DIMENSION  GGU),GGPCn#WRKS(l) 

DATA  kFlO/  4HGRID  / 


* if  there  is  no  packing,  write  the  label  and  field 

* DIRFCTLV  ONTO  file  NF  AND  RETURN. 

IF(NPACK.GT.l)  go  TO  25 
t AaNL6*NL AT 

WRITE (NF)  KFLD,IO,NAME,N,NLG,NLaT,NPaCK, (PG ( I ) , lal ,L A) 

WRITE (6, 620)  ID , Name , N, NLG, NL AT , NP ACK , NF 

return 

AN  ERROR  HAS  BEEN  ENCOUNTERED  IN  THE  LABEL  FIELD 

25  CALL  PPAK 
RETURN 


620  FORMAT ( 1 H ,60X, 15, 2X, Att, 13, 6H  GRID, 15, I«,BH  NPACK*, 12. 
I SH  TO  FILE, 13) 

END 
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